source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW25.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 8.6 KB
Line 
1SCRPW25 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 12/5/00 4:15pm
2 ;;5.3;Scheduling;**144,177,232**;AUG 13, 1993
3PEAO(SDX) ;Get agent orange indicator
4 K SDX S DFN=$P(SDOE0,U,2) I DFN D SVC^VADPT I $L(VASV(2)) S SDX(1)=VASV(2)_U_$S(VASV(2):"YES",1:"NO")
5 D NX Q
6 ;
7PEEC(SDX) ;Get environmental contaminants indicator
8 K SDX S SDX=$P($G(^DPT($P(SDOE0,U,2),.322)),U,13) I $L(SDX) D FST(.SDX,2,.322013) I $L($P(SDX,U,2)) S SDX(1)=SDX
9 D NX Q
10 ;
11PEIR(SDX) ;Get ionizing radiation indicator
12 K SDX S DFN=$P(SDOE0,U,2) I DFN D SVC^VADPT I $L(VASV(3)) S SDX(1)=VASV(3)_U_$S(VASV(3):"YES",1:"NO")
13 D NX Q
14 ;
15PEMT(SDX,SDZ) ;Get patient means test
16 K SDX N SDY S SDX=$$LST^DGMTU(+$P(SDOE0,U,2),$S(SDZ="H":+$P(SDOE0,U),1:DT)) I $L($P(SDX,U,4)) S SDY=$O(^DG(408.32,"C",$P(SDX,U,4),0)) I SDY S SDX(1)=SDY_U_$P(SDX,U,3)
17 D NX Q
18 ;
19PEMTQ(SDZ) ;Set up means test help text
20 I SDZ="H" S SDIRQ("?")="Means Test status as of the encounter date/time is used for 'historical' values."
21 I SDZ="C" S SDIRQ("?")="Means Test status as of the report run date is used for 'current' values."
22 Q
23 ;
24PEPE(SDX) ;Get patient primary eligibility
25 K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I $L($P(VAEL(1),U,2)) S SDX(1)=VAEL(1)
26 D NX Q
27 ;
28PEAE(SDX) ;Get all patient eligibilities
29 K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT M SDX=VAEL(1) I VAEL(1) S SDX(+VAEL(1))=VAEL(1)
30 D NX Q
31 ;
32PEPS(SDX) ;Get patient period of service
33 K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I $L($P(VAEL(2),U,2)) S SDX(1)=VAEL(2)
34 D NX Q
35 ;
36PEPW(SDX) ;Get patient POW indicated
37 K SDX S DFN=$P(SDOE0,U,2) I DFN D SVC^VADPT I $L(VASV(4)) S SDX(1)=VASV(4)_U_$S(VASV(4)=1:"YES",1:"NO")
38 D NX Q
39 ;
40PESP(SDX) ;Get service connected percentage
41 K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I VAEL(3) S SDX(1)=+$P(VAEL(3),U,2)_U_+$P(VAEL(3),U,2)
42 D NX Q
43 ;
44PEVT(SDX) ;Get veteran (y/n)?
45 K SDX S DFN=$P(SDOE0,U,2) I DFN D ELIG^VADPT I $L(VAEL(4)) S SDX(1)=$S(VAEL(4)=1:"Y^YES",1:"N^NO")
46 D NX Q
47 ;
48PRAP(SDX) ;Get all providers
49 K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^VA(200,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
50 D NX Q
51 ;
52PRPC(SDX,SDP) ;Get person class
53 K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0
54 F S SDI=$O(SDY(SDI)) Q:'SDI S SDX=$P(SDY(SDI),U,4) I $S(SDP="P"&(SDX="P"):1,SDP="S"&(SDX'="P"):1,SDP="A":1,1:0) S SDX=$P(SDY(SDI),U,6) I SDX S SDX=SDX_U_$P($$CODE2TXT^XUA4A72(SDX),U) I $L($P(SDX,U,2)) D PCOTR S SDX(SDI)=SDX Q:SDP="P"
55 D NX Q
56 ;
57PCOTR ;Person class output transform
58 N SDI,SDII,SDY S SDY=$G(^USC(8932.1,+SDX,0)) F SDI=2,3 S SDII=$P(SDY,U,SDI) S:$L(SDII) SDX=SDX_"/"_SDII
59 S SDX=$E(SDX,1,42) Q
60 ;
61PRPP(SDX) ;Get primary provider
62 K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI I $P(SDY(SDI),U,4)="P" S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^VA(200,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX Q
63 D NX Q
64 ;
65PRSP(SDX) ;Get secondary providers
66 K SDX N SDY,SDI D GETPRV^SDOE(SDOE,"SDY") S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI I $P(SDY(SDI),U,4)'="P" S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^VA(200,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
67 D NX Q
68 ;
69SCBC(SDX) ;Get both stop codes
70 K SDX S SDX=$P(SDOE0,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(1)=SDX
71 N SDI S SDI=0 F S SDI=$O(^SCE("APAR",SDOE,SDI)) Q:'SDI S SDOECH=$$GETOE^SDOE(SDI) I $P(SDOECH,U,8)=4 S SDX=$P(SDOECH,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(2)=SDX
72 D NX Q
73 ;
74SCPC(SDX) ;Get primary stop code
75 K SDX S SDX=$P(SDOE0,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(1)=SDX
76 D NX Q
77 ;
78SCSC(SDX) ;Get secondary stop code
79 K SDX N SDI S SDI=0 F S SDI=$O(^SCE("APAR",SDOE,SDI)) Q:'SDI S SDOECH=$$GETOE^SDOE(SDI) I $P(SDOECH,U,8)=4 S SDX=$P(SDOECH,U,3) I SDX S SDX=SDX_U_$P($G(^DIC(40.7,SDX,0)),U) I $L($P(SDX,U,2)) D SCOTR S SDX(2)=SDX
80 D NX Q
81 ;
82SCOTR ;Transform stop code external value
83 S $P(SDX,U,2)=$P(^DIC(40.7,+SDX,0),U,2)_" "_$P(SDX,U,2) Q
84 ;
85SCCP(SDX) ;Get stop code credit pair
86 K SDX N SDY D SCBC(.SDY) S SDX=$E($P(SDY(1),U,2),1,3) K:SDX'?3N SDX I $D(SDX) S SDX=SDX_$E($P($G(SDY(2)),U,2),1,3) S:SDX'?6N SDX=$E(SDX,1,3)_"000" D CPOTR S SDX(1)=SDX
87 D NX Q
88 ;
89CPOTR ;Credit pair output transform
90 N SDSC1,SDSC2,SDZ
91 S SDSC1=$O(^DIC(40.7,"C",$E(SDX,1,3),"")) Q:'SDSC1 S SDSC1=$P(^DIC(40.7,SDSC1,0),U),SDSC1=$TR(SDSC1,"/","-")
92 I $E(SDX,4,6)="000" S SDSC2="(NONE)" G CPO1
93 S SDSC2=$O(^DIC(40.7,"C",$E(SDX,4,6),"")) Q:'SDSC2 S SDSC2=$P(^DIC(40.7,SDSC2,0),U),SDSC2=$TR(SDSC2,"/","-")
94CPO1 I $L(SDSC1)<17 S SDZ=SDSC1_"/"_$E(SDSC2,1,(17+(17-$L(SDSC1)))) G CPOTQ
95 I $L(SDSC2)<17 S SDZ=$E(SDSC1,1,(17+(17-$L(SDSC2))))_"/"_SDSC2 G CPOTQ
96 S SDZ=$E(SDSC1,1,17)_"/"_$E(SDSC2,1,17)
97CPOTQ S $P(SDX,U,2)=$P(SDX,U)_" "_SDZ Q
98 ;
99VFEX(SDX) ;Get examinations
100 K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVXAM("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVXAM(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTEXAM(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
101 D NX Q
102 ;
103VFHF(SDX) ;Get health factors
104 K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVHF("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVHF(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTHF(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
105 D NX Q
106 ;
107VFIM(SDX) ;Get immunizations
108 K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVIMM("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVIMM(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTIMM(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
109 D NX Q
110 ;
111VFPE(SDX) ;Get patient education
112 K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVPED("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVPED(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTEDT(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
113 D NX Q
114 ;
115VFST(SDX) ;Get skin tests
116 K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVSK("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVSK(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTSK(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
117 D NX Q
118 ;
119VFTR(SDX) ;Get treatments
120 K SDX N SDY,SDI S SDY=+$P(SDOE0,U,5),SDI=0 F S SDI=$O(^AUPNVTRT("AD",SDY,SDI)) Q:'SDI S SDX=$P($G(^AUPNVTRT(SDI,0)),U),SDX=SDX_U_$P($G(^AUTTTRT(+SDX,0)),U) S:$L($P(SDX,U,2)) SDX(SDI)=SDX
121 D NX Q
122 ;
123NX S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~NONE~~~" Q
124 ;
125FST(SDX,SDFI,SDFE) ;Field set transform
126 Q:'$L(SDX) N SDY,SDI D FIELD^DID(SDFI,SDFE,"","POINTER","SDY") S SDY=SDY("POINTER") F SDI=1:1:$L(SDY,";") I SDX=$P($P(SDY,";",SDI),":") S SDX=SDX_U_$P($P(SDY,";",SDI),":",2) Q
127 Q
128 ;
129VETQ(DIR) ;Set up DIR array for 'veteran?' prompt
130 S DIR(0)="SO^Y:YES;N:NO",DIR("?")="Indicates if the patient served in the U.S. armed forces." Q
131 ;
132AOQ(DIR) ;Set up DIR array for agent orange prompt
133 S DIR(0)="SO^1:YES;0:NO",DIR("?")="Indicates if the patient was exposed to agent orange." Q
134 ;
135IRQ(DIR) ;Set up DIR array for ionizing radiation prompt
136 S DIR(0)="SO^1:YES;0:NO",DIR("?")="Indicates if the patient was exposed to ionizing radiation." Q
137 ;
138ECQ(DIR) ;Set up DIR array for environmental contaminants prompt
139 S DIR(0)="SO^Y:YES;N:NO;U:UNKNOWN",DIR("?")="Indicates if the patient was exposed to environmental contaminants." Q
140 ;
141POWQ(DIR) ;Set up DIR array for POW prompt
142 S DIR(0)="SO^1:YES;0:NO",DIR("?")="Indicates if the patient was a prisoner of war." Q
143 ;
144CPQ ;Credit pair help text
145 S SDIRQ("?",1)="Enter a six digit numeric value that represents two valid stop codes, or a",SDIRQ("?",2)="valid stop code followed by three zeros for clinics that do not have a (second)",SDIRQ("?")="credit stop code."
146 Q ; SD*5.3*232 TEJ - Q TO PREVENT CPQ OVERRUN INTO PCAP 11/28/00
147 ;
148PCAP(SDX,SDZ) ;Get primary care associate provider
149 ;Required input: SDZ="C" for current, "H" for historical
150 N SDI,SDATE,SDLIST,DFN
151 D VARZ(SDZ) S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST)
152 S SDX=$P($G(^TMP("SDPLIST",$J,DFN,"PCAP",1)),U,1,2)
153 I $L($P(SDX,U,2)) S SDX(1)=SDX
154 K ^TMP("SDPLIST",$J,DFN)
155 D NX Q
156 ;
157NPCP(SDX,SDZ) ;Get non-primary care provider information
158 ;Required input: SDZ="C" for current, "H" for historical
159 N SDI,SDATE,SDLIST,DFN
160 D VARZ(SDZ) S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST),SDI=0
161 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCPR",SDI)) Q:'SDI D
162 .S SDX=$P($G(^TMP("SDPLIST",$J,DFN,"NPCPR",SDI)),U,1,2)
163 .I $L($P(SDX,U,2)) S SDX(SDI)=SDX
164 .Q
165 K ^TMP("SDPLIST",$J,DFN)
166 D NX Q
167 ;
168NPCT(SDX,SDZ) ;Get non-primary care team information
169 ;Required input: SDZ="C" for current, "H" for historical
170 N SDI,SDATE,SDLIST,DFN
171 D VARZ(SDZ) S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDLIST),SDI=0
172 F S SDI=$O(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)) Q:'SDI D
173 .S SDX=$P($G(^TMP("SDPLIST",$J,DFN,"NPCTM",SDI)),U,1,2)
174 .I $L($P(SDX,U,2)) S SDX(SDI)=SDX
175 .Q
176 K ^TMP("SDPLIST",$J,DFN)
177 D NX Q
178 ;
179VARZ(SDZ) ;Produce variables
180 ;Input: SDZ="C" for current, "H" for historical
181 S SDLIST="^TMP(""SDPLIST"",$J)",DFN=+$P(SDOE0,U,2) K SDX,@SDLIST
182 S SDATE=$S(SDZ="C":DT,1:+$P(SDOE0,U))
183 S (SDATE("BEGIN"),SDATE("END"))=SDATE,SDATE="SDATE"
184 Q
Note: See TracBrowser for help on using the repository browser.