source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPCE3.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1ORWPCE3 ; SLC/KCM - Get a PCE encounter for a TIU document;11/21/03
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,190**;Dec 17, 1997
3 Q
4PCE4NOTE(LST,IEN,DFN,VSITSTR) ; Return encounter for an associated note
5 ; LST(1)=HDR^AllowEdit^CPTRequired^VStr^Author^hasCPT
6 ; LST(n)=TYP+^CODE^CAT^NARR^QUAL1^QUAL2 (QUAL1=Primary!Qty, QUAL2=Prv)
7 N VISIT,VSTR,ILST,LOC,CODE,PRIM,QTY,CAT,NARR,PRV,X0,X12,X802,X811,VTYP
8 N IPOV,ICPT,IPRV,IIMM,ISK,IPED,IHF,IXAM,ITRT,ICOM,MIDX,MIEN,MCNT,MODS
9 I +$G(IEN)<1 D I 1 ; Get PCE Data on a new note not yet saved
10 . S (X0,X12)=""
11 . S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";"))
12 . S VSTR=VSITSTR
13 E D
14 . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
15 . S VISIT=$P(X12,U,7)
16 . I 'VISIT S VISIT=$P(X0,U,3)
17 . D NOTEVSTR^ORWPCE(.VSTR,IEN)
18 S VTYP=$P(VSTR,";",3)
19 S ILST=1
20 S ICOM=0
21 S LST(1)="HDR"_U_("HID"[VTYP)_U_$P(X0,U,11)_U_VSTR_U_$P(X12,U,2)
22 ;add hasCPT node
23 S LST(1)=LST(1)_U_0
24 I VISIT'>0 D Q
25 . I $G(VSTR)'="" M LST=^TMP("ORWPCE",$J,VSTR) ; get cached visit data
26 I $P(LST(1),U,2),VTYP="H" Q ; quit if admission
27 K ^TMP("PXKENC",$J)
28 D ENCEVENT^PXAPI(VISIT)
29 I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
30 S $P(LST(1),U,6)=$D(^TMP("PXKENC",$J,VISIT,"CPT"))\10
31 S X0=^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),LOC=+$P(X0,U,22)
32 S ILST=ILST+1,LST(ILST)="VST^DT^"_$P(X0,U)
33 S ILST=ILST+1,LST(ILST)="VST^PT^"_$P(X0,U,5)
34 S ILST=ILST+1,LST(ILST)="VST^HL^"_LOC_"^^"_$P($G(^SC(LOC,0)),U)
35 S ILST=ILST+1,LST(ILST)="VST^PS^0" ;outpt
36 ;S X0=$G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800))
37 N VAL
38 D SCSEL^ORWPCE(.VAL,$P(X0,U,5),$P(X0,U),LOC,VISIT)
39 S ILST=ILST+1,LST(ILST)="VST^SC^"_$P($P(VAL,";",1),U,2)
40 S ILST=ILST+1,LST(ILST)="VST^AO^"_$P($P(VAL,";",2),U,2)
41 S ILST=ILST+1,LST(ILST)="VST^IR^"_$P($P(VAL,";",3),U,2)
42 S ILST=ILST+1,LST(ILST)="VST^EC^"_$P($P(VAL,";",4),U,2)
43 S ILST=ILST+1,LST(ILST)="VST^MST^"_$P($P(VAL,";",5),U,2)
44 I $P(VAL,";",6)'="" D
45 .S ILST=ILST+1,LST(ILST)="VST^HNC^"_$P($P(VAL,";",6),U,2)
46 I $P(VAL,";",7)'="" D
47 .S ILST=ILST+1,LST(ILST)="VST^CV^"_$P($P(VAL,";",7),U,2)
48 ;for provider
49 ; LST(n)="PRV"^ien^^^name^primary/secondary flag
50 S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D
51 . S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
52 . ;Q:$P(X0,U,4)'="P"
53 . S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
54 . S PRIM=($P(X0,U,4)="P")
55 . S ILST=ILST+1
56 . S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
57 S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D
58 . S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
59 . S CODE=$P(X0,U)
60 . S:CODE CODE=$P(^ICD9(CODE,0),U)
61 . S CAT=$P(X802,U)
62 . S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
63 . S NARR=$P(X0,U,4)
64 . S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
65 . S PRIM=($P(X0,U,12)="P")
66 . S PRV=$P(X12,U,4)
67 . S ILST=ILST+1
68 . S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
69 . I X811]"" D
70 .. S ICOM=ICOM+1
71 .. S $P(LST(ILST),U,10)=ICOM
72 .. S ILST=ILST+1
73 .. S LST(ILST)="COM"_U_ICOM_U_X811
74 S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D
75 . S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
76 . ;S CODE=$P(X0,U)
77 . S CODE=$O(^ICPT("B",$P(X0,U),0))
78 . S:CODE CODE=$P(^ICPT(CODE,0),U)
79 . S CAT=$P(X802,U)
80 . S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
81 . S NARR=$P(X0,U,4)
82 . S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
83 . S QTY=$P(X0,U,16)
84 . S PRV=$P(X12,U,4)
85 . S MCNT=0,MIDX=0,MODS=""
86 . F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D
87 . . S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
88 . . I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
89 . I +MCNT S MODS=MCNT_MODS
90 . S ILST=ILST+1
91 . S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
92 . I X811]"" D
93 .. S ICOM=ICOM+1
94 .. S $P(LST(ILST),U,10)=ICOM
95 .. S ILST=ILST+1
96 .. S LST(ILST)="COM"_U_ICOM_U_X811
97 ;for immunization:
98 ; LST(n)="IMM"^Code^^^Series^prv^Reaction^Contraindicated^Refused
99 S IIMM=0 F S IIMM=$O(^TMP("PXKENC",$J,VISIT,"IMM",IIMM)) Q:'IIMM D
100 . S X0=^TMP("PXKENC",$J,VISIT,"IMM",IIMM,0),X12=$G(^(12)),X811=$G(^(811))
101 . S CODE=$P(X0,U)
102 . S:CODE NARR=$P(^AUTTIMM(CODE,0),U)
103 . S QTY=$P(X0,U,4)
104 . S CAT=""
105 . S PRV=$P(X12,U,4)
106 . S ILST=ILST+1
107 . S LST(ILST)="IMM"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$P(X0,U,6,7)
108 . I X811]"" D
109 .. S ICOM=ICOM+1
110 .. S $P(LST(ILST),U,10)=ICOM
111 .. S ILST=ILST+1
112 .. S LST(ILST)="COM"_U_ICOM_U_X811
113 ;for skin test:
114 ; LST(n)="SK"^Code^^^result^prv^reading^d/t read^d/t given
115 S ISK=0 F S ISK=$O(^TMP("PXKENC",$J,VISIT,"SK",ISK)) Q:'ISK D
116 . S X0=^TMP("PXKENC",$J,VISIT,"SK",ISK,0),X12=$G(^(12)),X811=$G(^(811))
117 . S CODE=$P(X0,U)
118 . S:CODE NARR=$P(^AUTTSK(CODE,0),U)
119 . S QTY=$P(X0,U,4)
120 . S CAT=""
121 . S PRV=$P(X12,U,4)
122 . S ILST=ILST+1
123 . S LST(ILST)="SK"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$P(X0,U,5,6)_U_$P(X12,U)
124 . I X811]"" D
125 .. S ICOM=ICOM+1
126 .. S $P(LST(ILST),U,10)=ICOM
127 .. S ILST=ILST+1
128 .. S LST(ILST)="COM"_U_ICOM_U_X811
129 ;for patient education:
130 ; LST(n)="PED"^Code^^^level of understanding^prv
131 S IPED=0 F S IPED=$O(^TMP("PXKENC",$J,VISIT,"PED",IPED)) Q:'IPED D
132 . S X0=^TMP("PXKENC",$J,VISIT,"PED",IPED,0),X12=$G(^(12)),X811=$G(^(811))
133 . S CODE=$P(X0,U)
134 . S:CODE NARR=$P(^AUTTEDT(CODE,0),U)
135 . S QTY=$P(X0,U,6)
136 . S CAT=""
137 . S PRV=$P(X12,U,4)
138 . S ILST=ILST+1
139 . S LST(ILST)="PED"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
140 . I X811]"" D
141 .. S ICOM=ICOM+1
142 .. S $P(LST(ILST),U,10)=ICOM
143 .. S ILST=ILST+1
144 .. S LST(ILST)="COM"_U_ICOM_U_X811
145 ;for health factors:
146 ; LST(n)="HF"^Code^^^level/severity^prv
147 S IHF=0 F S IHF=$O(^TMP("PXKENC",$J,VISIT,"HF",IHF)) Q:'IHF D
148 . S X0=^TMP("PXKENC",$J,VISIT,"HF",IHF,0),X12=$G(^(12)),X811=$G(^(811))
149 . S CODE=$P(X0,U)
150 . S:CODE NARR=$P(^AUTTHF(CODE,0),U)
151 . S QTY=$P(X0,U,4)
152 . S CAT=""
153 . S PRV=$P(X12,U,4)
154 . S ILST=ILST+1
155 . S LST(ILST)="HF"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
156 . I X811]"" D
157 .. S ICOM=ICOM+1
158 .. S $P(LST(ILST),U,10)=ICOM
159 .. S ILST=ILST+1
160 .. S LST(ILST)="COM"_U_ICOM_U_X811
161 ;for exam:
162 ; LST(n)="XAM"^Code^^^result^prv
163 S IXAM=0 F S IXAM=$O(^TMP("PXKENC",$J,VISIT,"XAM",IXAM)) Q:'IXAM D
164 . S X0=^TMP("PXKENC",$J,VISIT,"XAM",IXAM,0),X12=$G(^(12)),X811=$G(^(811))
165 . S CODE=$P(X0,U)
166 . S:CODE NARR=$P(^AUTTEXAM(CODE,0),U)
167 . S QTY=$P(X0,U,4)
168 . S CAT=""
169 . S PRV=$P(X12,U,4)
170 . S ILST=ILST+1
171 . S LST(ILST)="XAM"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$P(X0,U,6,7)
172 . I X811]"" D
173 .. S ICOM=ICOM+1
174 .. S $P(LST(ILST),U,10)=ICOM
175 .. S ILST=ILST+1
176 .. S LST(ILST)="COM"_U_ICOM_U_X811
177 ;for treatment:
178 ; LST(n)="TRT"^Code^CAT^NARR^QTY^prv
179 S ITRT=0 F S ITRT=$O(^TMP("PXKENC",$J,VISIT,"TRT",ITRT)) Q:'ITRT D
180 . S X0=^TMP("PXKENC",$J,VISIT,"TRT",ITRT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
181 . S CODE=$P(X0,U)
182 . S QTY=$P(X0,U,4)
183 . S CAT=$P(X802,U)
184 . S NARR=$P(X0,U,6)
185 . S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
186 . S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
187 . S PRV=$P(X12,U,4)
188 . S ILST=ILST+1
189 . S LST(ILST)="TRT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
190 . I X811]"" D
191 .. S ICOM=ICOM+1
192 .. S $P(LST(ILST),U,10)=ICOM
193 .. S ILST=ILST+1
194 .. S LST(ILST)="COM"_U_ICOM_U_X811
195 Q
Note: See TracBrowser for help on using the repository browser.