source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPO2.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1SCRPO2 ;BP-CIOFO/KEITH - Historical Patient Position Assignment Listing (cont.) ;7/31/99 22:36
2 ;;5.3;Scheduling;**177**;AUG 13, 1993
3 ;
4BPTPA(SCPASS,SCDIV,SCTEAM,SCPOS,SCLINIC,SCFMT) ;Evaluate patient team position assignment information
5 ;Input: SCPASS=patient team position assignment information
6 ; string from $$PTTP^SCAPMC
7 ;Input: SCDIV=division^ifn
8 ;Input: SCTEAM=team^ifn
9 ;Input: SCPOS=team position^ifn
10 ;Input: SCLINIC=associated clinic^ifn (if one exists)
11 ;Input: SCFMT=report format (detail or summary)
12 ;
13 ;evaluate assignment/gather data
14 N SCPTPA,SCPTPA0,SCPC,DFN,SCPT0,SCACT,SCINACT,SCDT,SCPROV,SCX,SDOE0
15 N SCS,SCI,SCY,SCATY,SCAGE,SCARR,SCENRP,SCGEND,SCLAPP,SCMTST,SCNAPP
16 N SCPAT,SCPELIG,SCPTYP,SCSSN,ERR
17 S SCPTPA=$P(SCPASS,U,3) Q:SCPTPA<1 ;patient team position assignment
18 S SCPTPA0=$G(^SCPT(404.43,+SCPTPA,0)) Q:'$L(SCPTPA0)
19 S SCACT=$P(SCPTPA0,U,3),SCINACT=$P(SCPTPA0,U,4) ;activation dates
20 ;adjust dates if necessary
21 S:SCACT<^TMP("SC",$J,"DTR","BEGIN") SCACT=$P(^TMP("SC",$J,"DTR","BEGIN"),U)
22 I 'SCINACT!(SCINACT>^TMP("SC",$J,"DTR","END")) S SCINACT=$P(^TMP("SC",$J,"DTR","END"),U)
23 S SCPC=$P(SCPTPA0,U,5) Q:'$$PCROLE(.SCPC) ;pc role?
24 I $O(^TMP("SC",$J,"PCP",0)),SCPC="NO" Q ;no pc providers here
25 S DFN=$P(SCPASS,U),SCPT0=$G(^DPT(+DFN,0)) Q:'$L(SCPT0) ;patient node
26 Q:'$$PTCL(DFN,.SCLINIC,SCACT,SCINACT) ;enrolled clinic
27 S SCDT("BEGIN")=SCACT,SCDT("END")=SCINACT,SCDT("INCL")=0,SCDT="SCDT"
28 S SCARR="^TMP(""SCARR"",$J,2)" K @SCARR
29 S SCI=$$PRTPC^SCAPMC($P(SCPOS,U,2),.SCDT,SCARR,"ERR",1,1)
30 Q:'$$PROV(.SCPROV,SCPC) ;providers
31 S SCPAT=$P(SCPT0,U)_U_DFN ;patient name^dfn
32 S SCSSN=$P(SCPT0,U,9) ;patient ssn
33 S SCGEND=$S($P(SCPT0,U,2)="M":"MALE",1:"FEMALE") ;patient gender
34 S SCAGE=$$AGEGR($P(SCPT0,U,3)) ;patient age group
35 S SCPELIG=$$ELIG^SCRPO(DFN) ;primary eligibility
36 S SCMTST=$P($$LST^DGMTU(DFN,SCINACT),U,3,4) ;mt status
37 S:'$L(SCMTST) SCMTST="(not applicable)^"
38 K SCX S SDOE0=$P(^TMP("SC",$J,"DTR","END"),U)_U_DFN
39 D ENEP^SCRPW24(.SCX,"H") S SCENRP=$P(SCX(1),U,2) ;enrollment priority
40 ;
41 ;Set data string
42 S SCX=$E($P(SCPAT,U),1,18)_U_$E(SCSSN,6,10)
43 S SCX=SCX_U_$P(SCPELIG,U,2)_U_$P(SCMTST,U,2)
44 S SCX=SCX_U_$E($P(SCTEAM,U),1,13)_U_U_$E($P(SCPOS,U),1,14)_U
45 S SCX=SCX_U_$E($P(SCLINIC,U),1,14)
46 ;
47 ;Set line for each provider
48 S SCN=0 F S SCN=$O(SCPROV(SCN)) Q:'SCN D
49 .S SCPROV=$P(SCPROV(SCN),U,1,2),SCPTYP=$P(SCPROV(SCN),U,3)
50 .S SCATY=$S($P(SCPROV(SCN),U,4)="P":"PRECEPTOR PROVIDER",1:"ASSIGNED PROVIDER")
51 .S $P(SCX,U,6)=$E($P(SCPROV,U),1,14),$P(SCX,U,8)=SCPTYP
52 .S $P(SCX,U,10)=$P(SCPROV(SCN),U,5,6)
53 .;
54 .;Set sort values
55 .I SCFMT="D" F SCI=1:1:6 S SCS=$P($G(^TMP("SC",$J,"SORT",SCI)),U,3) D
56 ..I $L(SCS) S SCY=@SCS S:'$L(SCY) SCY="~~~"
57 ..S:'$L(SCS) SCY="~~~" S SCS(SCI)=SCY
58 ..Q
59 .;Set report detail global
60 .I SCFMT="D" D LSET(.SCS,SCX)
61 .;
62 .;Set report statistics nodes
63 .S ^TMP("SCRPT",$J,0,SCATY,SCPROV)=$G(^TMP("SCRPT",$J,0,SCATY,SCPROV))+1
64 I $L(SCPELIG) S ^TMP("SCRPT",$J,0,"PRIMARY ELIGIBILITY",SCPELIG)=$G(^TMP("SCRPT",$J,0,"PRIMARY ELIGIBILITY",SCPELIG))+1
65 I $L(SCMTST) S ^TMP("SCRPT",$J,0,"MEANS TEST CATEGORY",SCMTST)=$G(^TMP("SCRPT",$J,0,"MEANS TEST CATEGORY",SCMTST))+1
66 S ^TMP("SCRPT",$J,0,"GENDER",SCGEND)=$G(^TMP("SCRPT",$J,0,"GENDER",SCGEND))+1
67 S ^TMP("SCRPT",$J,0,"AGE GROUP",SCAGE)=$G(^TMP("SCRPT",$J,0,"AGE GROUP",SCAGE))+1
68 S ^TMP("SCRPT",$J,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP)=$G(^TMP("SCRPT",$J,0,"NATIONAL ENROLLMENT PRIORITY",SCENRP))+1
69 S ^TMP("SCRPT",$J,0,"TEAM",SCTEAM)=$G(^TMP("SCRPT",$J,0,"TEAM",SCTEAM))+1
70 S ^TMP("SCRPT",$J,0,"PRIMARY CARE",SCPC)=$G(^TMP("SCRPT",$J,0,"PRIMARY CARE",SCPC))+1
71 S ^TMP("SCRPT",$J,0,"DIVISION",SCDIV)=$G(^TMP("SCRPT",$J,0,"DIVISION",SCDIV))+1
72 S ^TMP("SCRPT",$J,0,"ASSIGNMENTS")=$G(^TMP("SCRPT",$J,0,"ASSIGNMENTS"))+1
73 S ^TMP("SCRPT",$J,0,"UNIQUES",DFN)=""
74 Q
75 ;
76LSET(SCS,SCX) ;Set report line
77 ;Input: SCS=array of sort values
78 ;Input: SCX=data string
79 N SCI,SCN,SCL
80 S SCN=$G(^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))) I 'SCN D
81 .S ^TMP("SCRPT",$J,1)=$G(^TMP("SCRPT",$J,1))+1
82 .S SCN=^TMP("SCRPT",$J,1)
83 .S ^TMP("SCRPT",$J,1,SCS(1),SCS(2),SCS(3))=SCN
84 .Q
85 S ^TMP("SCRPT",$J,2)=$G(^TMP("SCRPT",$J,2))+1
86 S SCL=^TMP("SCRPT",$J,2)
87 S ^TMP("SCRPT",$J,2,SCN,SCS(4),SCS(5),SCS(6),SCL)=SCX
88 Q
89 ;
90PROV(SCPROV,SCPC) ;evaluate providers
91 ;Input: SCPROV=variable to return array of provider^ifn^type
92 ;Input: SCPC=pc? yes/no
93 ;Output: '1' if successful, '0' otherwise
94 ;
95 N SCI,SCPCF,SCFOUND,SCFPC,SCFAS,SCPRD,SCN,SCSUB,SCLEV,SCR,SCPP
96 S SCFPC=$O(^TMP("SC",$J,"PCP",0))>0 ;find pc provider flag
97 S SCFAS=$O(^TMP("SC",$J,"ASPR",0))>0 ;find assigned provider flag
98 S SCPCF=$S(SCPC="NO":0,$D(^TMP("SCARR",$J,2,"PPROV")):2,1:1),SCN=0
99 S SCFOUND=$S(SCFPC!SCFAS:0,1:1) ;success indicator
100 S SCPP=0,SCR="" F S SCR=$O(^TMP("SCARR",$J,2,SCR)) Q:'SCR!SCPP D
101 .S:$D(^TMP("SCARR",$J,2,SCR,"PREC")) SCPP=1
102 .Q ;Preceptor position flag
103 I SCFAS D ;Find selected assigned providers
104 .S SCR=""
105 .F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
106 ..S SCI=""
107 ..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-P",SCI)) Q:SCI="" D
108 ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-P",SCI)
109 ...I $D(^TMP("SC",$J,"ASPR",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",SCPP) S SCFOUND=1
110 ...Q
111 ..Q
112 .S SCR=""
113 .F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
114 ..S SCI=""
115 ..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)) Q:SCI="" D
116 ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)
117 ...I $D(^TMP("SC",$J,"ASPR",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",0) S SCFOUND=1
118 ...Q
119 ..Q
120 .Q
121 I SCFPC,'SCPP D ;Find selected pc providers in top level
122 .S SCR=""
123 .F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
124 ..S SCI=""
125 ..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)) Q:SCI="" D
126 ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PROV-U",SCI)
127 ...I $D(^TMP("SC",$J,"PCP",+SCPRD)) D PSET(SCPRD,SCPC,1,.SCN,"A",SCPP) S SCFOUND=1
128 ...Q
129 ..Q
130 .Q
131 I SCFPC,SCPP D ;Find selected pc providers in preceptor level
132 .S SCR=""
133 .F S SCI=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
134 ..S SCI=""
135 ..F S SCI=$O(^TMP("SCARR",$J,2,SCR,"PREC",SCI)) Q:SCI="" D
136 ...S SCPRD=^TMP("SCARR",$J,2,SCR,"PREC",SCI)
137 ...I $D(^TMP("SC",$J,"PCP",+SCPRD)) D PSET(SCPRD,SCPC,2,.SCN,"P",SCPP) S SCFOUND=1
138 ...Q
139 ..Q
140 .Q
141 I SCFAS!SCFPC Q SCFOUND
142 ;Get all providers
143 S SCR="" F S SCR=$O(^TMP("SCARR",$J,2,SCR)) Q:SCR="" D
144 .F SCSUB="PROV-P","PROV-U","PREC" S SCI="" D
145 ..Q:SCPC="NO"&(SCSUB="PREC") ;no preceptors for non-pc
146 ..S SCLEV=$S(SCSUB="PREC":2,1:1)
147 ..F S SCI=$O(^TMP("SCARR",$J,2,SCR,SCSUB,SCI)) Q:SCI="" D
148 ...S SCPRD=^TMP("SCARR",$J,2,SCR,SCSUB,SCI)
149 ...D PSET(SCPRD,SCPC,SCLEV,.SCN,$S(SCSUB="PREC":"P",1:"A"),$S(SCSUB="PROV-U":0,1:SCPP))
150 ...Q
151 ..Q
152 .Q
153 I '$O(SCPROV(0)) S SCPROV(1)="[not assigned]"_U_U_$S(SCPCF=0:"NPC",SCPCF=2:" AP",1:"PCP")
154 Q SCFOUND
155 ;
156PSET(SCPRD,SCPC,SCLEV,SCN,SCATY,SCPP) ;Set local provider array
157 ;Input: SCRPD=provider data from PRTPC^SCAPMC
158 ;Input: SCPC=pc? yes/no
159 ;Input: SCLEV='1' for assigned position, '2' for preceptor position
160 ;Input: SCN=array incrementing number
161 ;Input: SCPTY='A' for assigned provider, 'P' for preceptor provider
162 ;Input: SCPP='1' if preceptor position exists, '0' otherwise
163 N SCPRTY
164 S SCPRTY=$S(SCPC="NO":"NPC",SCLEV=1&SCPP:" AP",1:"PCP")
165 I SCATY="P",$P(SCPRD,U,14)>$P(SCPRD,U,9) D
166 .S $P(SCPRD,U,9)=$P(SCPRD,U,14),$P(SCPRD,U,10)=$P(SCPRD,U,15)
167 .Q
168 S SCN=SCN+1
169 S SCPROV(SCN)=$S($P(SCPRD,U,2)="":"[not assigned]",1:$P(SCPRD,U,2))
170 S SCPROV(SCN)=SCPROV(SCN)_U_+SCPRD_U_SCPRTY_U_SCATY_U
171 S SCPROV(SCN)=SCPROV(SCN)_$$DT($P(SCPRD,U,9))_U_$$DT($P(SCPRD,U,10))
172 Q
173 ;
174DT(X) ;Transform date
175 S X=$E(X,1,7) Q:X'?7N ""
176 Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(17+$E(X))_$E(X,2,3)
177 ;
178PCROLE(SCPC) ;Determine PC? y/n
179 ;Input: SCPC=pc role from file #404.43 (output as 'yes' or 'no' if successful)
180 ;Output: '1' if successful, '0' otherwise
181 ;
182 I $E(^TMP("SC",$J,"ATYPE"))="P",SCPC<1 Q 0
183 I $E(^TMP("SC",$J,"ATYPE"))="N",SCPC>0 Q 0
184 S SCPC=$S(SCPC>0:"YES",1:"NO")
185 Q 1
186 ;
187PTCL(DFN,SCLINIC,SCACT,SCINACT) ;evaluate enrolled clinic
188 ;Input: DFN=patient ifn
189 ;Input: SCLINIC=team position associated clinic
190 ; (returned if successful and enrolled, null otherwise)
191 ;Output: '1' if successful, '0' otherwise
192 ;
193 N SCIFN,SCPE,ENR,SCPED,SCPED0
194 S SCIFN=$P(SCLINIC,U,2) Q:'SCIFN 1 ;not required, no associated clinic
195 I $D(^TMP("SC",$J,"CLINIC",SCIFN)),'$D(^DPT(DFN,"DE","B",SCIFN)) Q 0
196 ;required, never enrolled
197 S (ENR,SCPE)=0
198 F S SCPE=$O(^DPT(DFN,"DE","B",SCIFN,SCPE)) Q:'SCPE!ENR D
199 .S SCPED=0 F S SCPED=$O(^DPT(DFN,"DE",SCPE,1,SCPED)) Q:'SCPED!ENR D
200 ..S SCPED0=$G(^DPT(DFN,"DE",SCPE,1,SCPED,0)) Q:'+SCPED0
201 ..I $P(SCPED0,U,3),$P(SCPED0,U,3)'<SCACT,+SCPED0'>SCINACT S ENR=1 Q
202 ..I '$P(SCPED0,U,3),+SCPED0'>SCINACT S ENR=1
203 ..Q
204 .Q
205 I $D(^TMP("SC",$J,"CLINIC",SCIFN)),'ENR S SCLINIC="" Q 0
206 I '$D(^TMP("SC",$J,"CLINIC",SCIFN)),'ENR S SCLINIC="" Q 1
207 Q 1
208 ;
209AGEGR(SCDT) ;Calculate age group
210 ;Input: SCDT=patient birth date
211 N X,Y,X1,X2
212 S X1=DT,X2=SCDT D ^%DTC Q:X<0 "unknown"
213 S X=X\365.4 Q:X<5 "0 - 4"
214 S Y=X\5 S:'(Y#2) Y=Y-1
215 Q (Y*5)_" - "_(Y*5+9)
Note: See TracBrowser for help on using the repository browser.