source: WorldVistAEHR/trunk/r/CARE_MANAGEMENT-ORRC/ORRCACK.m@ 1800

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

initial load of WorldVistAEHR
File size: 9.4 KB
Line 
1ORRCACK ;SLC/MKB - Result Acknowledgement file utilities ; 25 Jul 2003 9:31 AM
2 ;;1.0;CARE MANAGEMENT;;Jul 15, 2003
3 ;
4 ; ID = "ORR:"_order# everywhere below
5 ;
6PARAM(PROV) ; -- Return ORRC ACTIVATION DATE parameter for PROV
7 N SERV,Y S PROV=+$G(PROV),SERV=+$G(^VA(200,PROV,5))
8 S Y=$$GET^XPAR("ALL^USR.`"_PROV_"^SRV.`"_SERV,"ORRC ACTIVATION DATE")
9 Q Y
10 ;
11ADD(ORDER,PROV,ACK) ; -- Create new entry in file #102.4 when results are posted
12 ; [called from HL7 messages: ORMLR, ORMRA, ORMGMRC]
13 Q:'$G(ORDER) N X,Y,DIC,DO,STOP
14 I '$G(ACK),+$G(PROV) D Q:$G(STOP)
15 . I $D(^ORA(102.4,"ACK",PROV,+$G(ORDER))) S STOP=1 Q ;exists
16 . N ACTDT S ACTDT=$$PARAM(PROV)
17 . I (ACTDT<1)!(ACTDT>DT) S STOP=1 Q ;not [yet] active
18 S DIC="^ORA(102.4,",DIC(0)="" S:$G(PROV) DIC("DR")="2////"_+PROV
19 S X=+ORDER D FILE^DICN
20 Q
21 ;
22ACK(ORY,ORUSR,ORDER) ; -- Acknowledge results of ORDERs by ORUSR
23 ; where ORDER(#) = ID ^ 1 or 0, if acknowledged
24 ; Returns ORY(#) = ID ^ 1 or 0, if successful
25 ; RPC = ORRC RESULTS ACKNOWLEDGE
26 Q:'$G(ORUSR) N X,Y,DA,DR,DIE,ORI,ORIFN,ORACK,ORXQ
27 S DIE="^ORA(102.4,",ORUSR=+$G(ORUSR)
28 S ORI="" F S ORI=$O(ORDER(ORI)) Q:ORI="" D
29 . S X=ORDER(ORI),ORIFN=$P(X,U),ORACK=+$P(X,U,2)
30 . S ORY(ORI)=ORIFN_"^0",ORIFN=+$P(ORIFN,":",2) Q:ORIFN<1
31 . I '$D(^ORA(102.4,"ACK",+ORUSR,+ORIFN)) D ADD(ORIFN,ORUSR,1)
32 . S DA=+$O(^ORA(102.4,"ACK",+ORUSR,+ORIFN,0)) Q:DA<1
33 . S DR="3///"_$S(ORACK:"NOW",1:"@") D ^DIE
34 . S $P(ORY(ORI),U,2)=1,ORXQ(+ORIFN)=""
35 D:$D(ORXQ) RSLT^ORRCXQ(.ORXQ,ORUSR)
36 Q
37 ;
38DEL(DA) ; -- Delete old acknowledgment stub
39 N DIK S DIK="^ORA(102.4,"
40 I $G(DA),'$P($G(^ORA(102.4,DA,0)),U,3) D ^DIK
41 Q
42 ;
43PATS(ORY,ORUSR) ; -- Return list of patients for whom ORUSR has unack'd results
44 ; in @ORY@(PAT) = #orders ^ 1 if any are abnormal
45 ; @ORY@(PAT,ID) = * if abnormal, else null
46 ; [from ORRCDPT]
47 N ORIFN,PAT,ABN,X,CNT,ACTDT,RDT,ACK
48 S ORUSR=+$G(ORUSR),ACTDT=$$PARAM(ORUSR)
49 S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY,^TMP($J,"ORSLT")
50 S ORIFN=0 F S ORIFN=+$O(^ORA(102.4,"ACK",ORUSR,ORIFN)) Q:ORIFN<1 D
51 . Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
52 . S PAT=+$P($G(^OR(100,ORIFN,0)),U,2),RDT=+$G(^(7)),ABN=$P($G(^(7)),U,2)
53 . I $D(^TMP($J,"ORRCLST")),'$D(^TMP($J,"ORRCY",PAT)) Q ;pt not on list
54 . I 'ACTDT!(RDT<ACTDT) S ACK=+$O(^ORA(102.4,"ACK",ORUSR,ORIFN,0)) D DEL(ACK) Q ;remove old stub
55 . S X=$G(ORY(PAT)),CNT=+X
56 . S CNT=CNT+1,@ORY@(PAT)=CNT_$S(ABN!$P(X,U,2):"^1",1:"")
57 . S @ORY@(PAT,"ORR:"_ORIFN)=$S(ABN:"*",1:"")
58 . D ORSLT ;temp xref for PATS^ORRCEVT
59 Q
60 ;
61ORSLT ; -- Add ORIFN to ^TMP($J,"ORSLT",PAT,pkgid) for use by Events
62 N OR0,OR4,NMSP,X
63 S OR0=$G(^OR(100,+ORIFN,0)),OR4=$G(^(4)),X=""
64 S NMSP=$$NMSP^ORCD($P(OR0,U,14)) I NMSP="RA" D Q
65 . N IDX S IDX="^RADPT(""AO"",+OR4,PAT)"
66 . F S IDX=$Q(@IDX) Q:$P(IDX,",",2)'=+OR4 Q:$P(IDX,",",3)'=PAT S X=$P(IDX,",",4)_"~"_$P(IDX,",",5),^TMP($J,"ORSLT",PAT,X)=+ORIFN
67 I NMSP="LR" S X=+ORIFN_"@OR"
68 I NMSP="GMRC" S X=+OR4
69 S:$L(X) ^TMP($J,"ORSLT",PAT,X)=+ORIFN
70 Q
71 ;
72IDS(ORY,ORPAT,ORUSR,SDATE,EDATE) ; -- Return new results for ORPAT
73 ; between ORBEG & OREND that ORUSR has not acknowledged
74 ; in @ORY@(ORPAT) = #orders ^ 1 if any are abnormal
75 ; @ORY@(ORPAT,ID) = * if abnormal, else null
76 ; [from ORRCDPT1]
77 N CNT,ORIFN,ORDT,ABN,X
78 S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
79 S ORUSR=+$G(ORUSR),ORPAT=+$G(ORPAT)_";DPT(",CNT=0
80 S SDATE=$G(SDATE),EDATE=$G(EDATE) D DT1 ;defaults ??
81 S ORDT=SDATE F S ORDT=$O(^OR(100,"ARS",ORPAT,ORDT)) Q:ORDT<1 Q:ORDT>EDATE D
82 . S ORIFN=0 F S ORIFN=+$O(^OR(100,"ARS",ORPAT,ORDT,ORIFN)) Q:ORIFN<1 D
83 .. Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
84 .. Q:$$ACKD(ORIFN,ORUSR) S CNT=CNT+1,X=$P($G(^OR(100,ORIFN,7)),U,2)
85 .. S @ORY@(+ORPAT,"ORR:"_ORIFN)=$S(X:"*",1:"") S:X ABN=1
86 S:CNT @ORY@(+ORPAT)=CNT_U_$G(ABN)
87 Q
88 ;
89LIST(ORY,ORUSR,ORPAT,ORSLT) ; -- Return orders by ORUSR for ORPAT with new results
90 ; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and also if ORSLT
91 ; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
92 ; = Cmnt=result comment
93 ; or Text=line of report text
94 ; RPC = ORRC RESULTS BY PATIENT
95 N ORN,ORIFN,ORTX,ORDT
96 S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
97 S ORUSR=+$G(ORUSR),ORPAT=+$G(ORPAT),ORN=0
98 S ORIFN=0 F S ORIFN=+$O(^ORA(102.4,"ACK",ORUSR,ORIFN)) Q:ORIFN<1 I +$P($G(^OR(100,ORIFN,0)),U,2)=ORPAT D
99 . Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
100 . D TEXT^ORQ12(.ORTX,ORIFN) S ORDT=+$G(^OR(100,ORIFN,7))
101 . S ORN=ORN+1,@ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
102 . I $G(ORSLT) D ORD ;add results data to ORY(#)
103 ;S ORY(0)=CNT
104 Q
105 ;
106LISTD(ORY,ORPAT,ORUSR,ORBEG,OREND,ORSLT) ; -- Return new results for ORPAT
107 ; between ORBEG & OREND that ORUSR has not acknowledged
108 ; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and also if ORSLT
109 ; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
110 ; = Cmnt=result comment
111 ; or Text=line of report text
112 ; RPC = ORRC RESULTS BY DATE
113 N ORN,ORIFN,ORTX,ORDT,SDATE,EDATE
114 S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
115 S ORUSR=+$G(ORUSR),ORPAT=+$G(ORPAT)_";DPT(",ORN=0 D DATES
116 S ORDT=SDATE F S ORDT=$O(^OR(100,"ARS",ORPAT,ORDT)) Q:ORDT<1 Q:ORDT>EDATE D
117 . S ORIFN=0 F S ORIFN=+$O(^OR(100,"ARS",ORPAT,ORDT,ORIFN)) Q:ORIFN<1 D
118 .. Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
119 .. Q:$$ACKD(ORIFN,ORUSR) D TEXT^ORQ12(.ORTX,ORIFN)
120 .. S ORN=ORN+1,@ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
121 .. I $G(ORSLT) D ORD ;add results data to ORY(#)
122 Q
123 ;
124DATES ; -- Return SDATE and EDATE from ORBEG and OREND
125 ; [Inverted for rev-chron search]
126 S SDATE=$$HL7TFM^XLFDT($G(ORBEG)),EDATE=$$HL7TFM^XLFDT($G(OREND))
127DT1 I EDATE S EDATE=$S($L(EDATE,".")=2:EDATE+.0001,1:EDATE+1)
128 I SDATE S SDATE=$S($L(SDATE,".")=2:SDATE-.0001,1:SDATE)
129 S SDATE=9999999-$S(SDATE:SDATE,1:0),EDATE=9999999-$S(EDATE:EDATE,1:9999998)
130 S X=EDATE,EDATE=SDATE,SDATE=X
131 Q
132 ;
133ACKD(ORDER,USER) ; -- Returns 1 or 0, if USER has acknowledged ORDER
134 N Y S Y=0
135 S IFN=0 F S IFN=$O(^ORA(102.4,"B",+$G(ORDER),IFN)) Q:IFN<1 D Q:Y
136 . S X=$G(^ORA(102.4,IFN,0)) I $P(X,U,3),$P(X,U,2)=+$G(USER) S Y=1 Q
137 Q Y
138 ;
139RESULT(ORY,ORDER) ; -- Return results of ORDERs
140 ; where ORDER(#) = ID
141 ; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and
142 ; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
143 ; = Cmnt=result comment
144 ; or Text=line of report text
145 ; RPC = ORRC RESULTS BY ID
146 N ORN,ORI,ORIFN,ORDT,ORTX
147 S ORN=0,ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
148 S ORI="" F S ORI=$O(ORDER(ORI)) Q:ORI="" S ORIFN=ORDER(ORI) D
149 . S ORIFN=+$P(ORIFN,":",2),ORDT=+$G(^OR(100,ORIFN,7))
150 . D TEXT^ORQ12(.ORTX,ORIFN)
151 . S ORN=ORN+1,@ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
152 . D ORD
153 Q
154 ;
155ORD ; -- Add results for ORIFN to @ORY@(ORN)
156 N PKG Q:'+$G(ORIFN)
157 S PKG=+$P($G(^OR(100,ORIFN,0)),U,14),PKG=$$NMSP^ORCD(PKG)
158 I "^LR^RA^GMRC^"'[(U_PKG_U)!'ORIFN S ORY(1)="Text=No results available." Q ;DT??
159 D @PKG
160 Q
161LR ; -- Lab results
162 N ORVP,LRID,LRTST,LRSUB,I,X K ^TMP("LRRR",$J)
163 S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),LRID=$G(^(4))
164 I '$L(LRID) S ORN=ORN+1,@ORY@(ORN)="Text=No results available." Q
165 S X=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE"),LRTST=+$P($G(^ORD(101.43,+X,0)),U,2)
166 I +LRID D RR^LR7OR1(+ORVP,LRID,,,,LRTST) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(LRID,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63
167 I '+LRID,$P(LRID,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(LRID,";",5),9999999-$P(LRID,";",5),$P(LRID,";",4),LRTST)
168 I '$D(^TMP("LRRR",$J,+ORVP)) S ORN=ORN+1,@ORY@(ORN)="Text=No results available." Q
169 S LRSUB=$O(^TMP("LRRR",$J,+ORVP,"")) Q:LRSUB=""
170 S LRDT=$O(^TMP("LRRR",$J,+ORVP,LRSUB,0)) I LRDT S LRDT=9999999-LRDT,$P(@ORY@(ORN),U,3)=$$FMTHL7^XLFDT(LRDT) ;return Coll Dt instead of Results Dt
171 I LRSUB="CH" D K ^TMP("LRRR",$J) Q
172 . N TEST,LRDT,LRN,LRI M TEST=^TMP("LRRR",$J,+ORVP,"CH")
173 . S LRDT=0 F S LRDT=$O(TEST(LRDT)) Q:LRDT<1 S LRN=0 F S LRN=$O(TEST(LRDT,LRN)) Q:LRN="" D
174 .. I LRN S I=$G(TEST(LRDT,LRN)),X=$P($G(^LAB(60,+I,0)),U)_U_$P(I,U,2)_U_$P(I,U,4,5)_U_$P(I,U,3) S ORN=ORN+1,@ORY@(ORN)="Data="_X
175 .. I LRN="N" S LRI=0 F S LRI=$O(TEST(LRDT,LRN,LRI)) Q:LRI<1 S ORN=ORN+1,@ORY@(ORN)="Cmnt="_$G(TEST(LRDT,LRN,LRI))
176 K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP):LRSUB="BB",EN^LR7OSMZ0(+ORVP):LRSUB="MI"
177 S I=0 F S I=+$O(^TMP("LRC",$J,I)) Q:I<1 S X=$G(^(I,0)),ORN=ORN+1,@ORY@(ORN)="Text="_X
178 K ^TMP("LRC",$J),^TMP("LRRR",$J)
179 Q
180RA ; -- Radiology results
181 N ORVP,RAID,CASE,PROC,PSET,FIRST
182 S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),RAID=+$G(^(4)) D EN30^RAO7PC3(RAID)
183 S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")),FIRST=1
184 I 'PSET S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D
185 . S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D XRPT
186 I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D XRPT
187 K ^TMP($J,"RAE3",+ORVP)
188 Q
189XRPT ; -- body of report for CASE, PROC
190 N ORD,X,I
191 I 'FIRST S ORN=ORN+1,@ORY@(ORN)="Text="_$$REPEAT^XLFSTR(" * ",24)
192 S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S ORN=ORN+1,@ORY@(ORN)="Text=Proc Ord: "_ORD
193 S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),ORN=ORN+1,@ORY@(ORN)="Text="_X ;Skip pt ID on line 1
194 S FIRST=0
195 Q
196GMRC ; -- Consult results
197 N GMRCID,I,X,SUB S GMRCID=+$G(^OR(100,ORIFN,4)),SUB="RT" N ORIFN ;protect
198 I '$D(^GMR(123,GMRCID,50,"B")),'$D(^GMR(123,GMRCID,51,"B")) S SUB="DT"
199 D RT^GMRCGUIA(GMRCID,"^TMP(""GMRCR"",$J,""RT"")"):SUB="RT",DT^GMRCSLM2(GMRCID):SUB="DT"
200 S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),ORN=ORN+1,@ORY@(ORN)="Text="_X
201 K ^TMP("GMRCR",$J)
202 Q
Note: See TracBrowser for help on using the repository browser.