source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m@ 613

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

initial load of WorldVistAEHR
File size: 7.6 KB
Line 
1ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions ;5/30/06 14:50
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213,243**;Dec 17, 1997;Build 242
3 ;
4ACTDCREA(DCIEN) ; Valid DC Reason
5 N X
6 S X=$G(^ORD(100.03,DCIEN,0))
7 I $P(X,U,4) Q 0
8 I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q 0
9 I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q 0
10 Q 1
11 ;
12ISREL(VAL,ORIFN) ; Return true if an order has been released
13 N STS S STS=$P(^OR(100,+ORIFN,3),U,3)
14 S VAL=$S(STS=10:0,STS=11:0,1:1) ; false if delayed or unreleased order
15 Q
16RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order
17 N ORDG
18 N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG
19 N ORDIALOG,PRMT,X0
20 N FSTDOSE,FST
21 S (FSTDOSE,FST)=0
22 I '$D(CPLX) S CPLX=0
23 I '$G(ORAPPT) S ORAPPT=""
24 S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
25 S X0=^OR(100,+ORIFN,0)
26 S ORDG=$P(X0,U,11)
27 S ORPKG=$P(X0,U,14)
28 I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK")
29 I $P(X0,U,5)["101.41," D ; version 3
30 . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
31 . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
32 . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW")
33 . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1)
34 E D ; version 2.5 generic
35 . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
36 . D GETDLG^ORCD(ORDIALOG)
37 . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
38 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
39 . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
40 . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
41 . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
42 I +FLDS(1)=999 D ; generic order
43 . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2)
44 . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3)
45 I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D
46 . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
47 . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12)
48 . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
49 . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
50 . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
51 . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2)
52 . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP) ; dflt doses
53 . D D1^ORCDPS2 ; set up ORDOSE
54 . S DRUG=$G(ORDOSE("DD",+ORDRUG))
55 . I DRUG,ORCAT="O" D RESETID^ORCDPS
56 . D SIG^ORCDPS2
57 I +FLDS(1)=140 D ; outpatient meds
58 . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt
59 . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4)
60 . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5)
61 . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
62 . K ^TMP("ORWORD",$J,PRMT,1)
63 . S I=1 F S I=$O(FLDS(I)) Q:'I S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I)
64 . S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
65 . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
66 . N SIG,PI,X S SIG=$$PTR^ORCD("OR GTX SIG")
67 . S PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS"),X=$$STR(PI)
68 . I $L(X),$$STR(SIG)[X S ORDIALOG(PI,"FORMAT")="@" ;PI in Sig
69 D RN^ORCSAVE
70 S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
71 Q
72RNWFLDS(LST,ORIFN) ; Return fields for renew action
73 ; LST(0)=RenewType^Start^Stop^Refills^Pickup LST(n)=Comments
74 N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI
75 S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14)
76 S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3)
77 S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0)
78 I +LST(0)=140 D
79 . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")
80 . ;D WPVAL(.LST,ORIFN,"COMMENT")
81 I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
82 ; make sure start/stop times are relative times, otherwise use NOW, no Stop
83 I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW"
84 I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)=""
85 ;NEW STUFF AFTER THIS LINE OR*3*243
86 S $P(LST(0),U,9)=0
87 S OROI=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0))
88 Q:'OROI
89 S OROI=$G(^OR(100,+ORIFN,4.5,OROI,1))
90 Q:'OROI
91 S $P(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI)
92 ; add to LST node specifying if patient of ORIFN passes clozapine lab tests
93 I $P(LST(0),U,9) D
94 .N ORY,ORDFN,ORTMP
95 .S ORTMP=LST(0)
96 .K LST
97 .S LST(0)=ORTMP
98 .S ORDFN=$P(^OR(100,ORIFN,0),U,2)
99 .I $P(ORDFN,";",2)'="DPT(" Q
100 .S ORDFN=+ORDFN
101 .D ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E")
102 .M LST(1)=ORY
103 Q
104VAL(ORIFN,ID) ; Return value for order response
105 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
106 Q $G(^OR(100,ORIFN,4.5,DA,1))
107WPVAL(TXT,ORIFN,ID) ; Return word processing value
108 N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
109 S I=0 F S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I S TXT(I)=^(I,0)
110 Q
111STR(PTR) ; -- Return word processing text as long string for comparison
112 N X,Y,I,ARRY
113 S ARRY=$G(ORDIALOG(+$G(PTR),1)) Q:'$L(ARRY) ""
114 S I=+$O(@ARRY@(0)),Y=$$UP^XLFSTR($G(@ARRY@(I,0)))
115 F S I=+$O(@ARRY@(I)) Q:'I S X=$G(@ARRY@(I,0)),Y=Y_$$UP^XLFSTR(X)
116 S Y=$TR(Y," ") ;remove all spaces, compare only text
117 Q Y
118CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order
119 N ORACT,ORWERR
120 ; begin case
121 S ORACT=""
122 I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1
123 I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1
124 I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1
125 I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES"
126XC1 ; end case
127 S ORWERR=""
128 I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR=""
129 Q ORWERR
130GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN
131 S ORIFN=+ORIFN
132 S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
133 Q
134GETPKG(Y,IFN) ;Get package for an order
135 N ORDERID,PKGID
136 Q:+IFN<1
137 S ORDERID=+IFN,Y=""
138 S PKGID=$P(^OR(100,ORDERID,0),U,14)
139 S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
140 Q
141ISCPLX(ORY,ORID) ; 1: is complex order 0: is not
142 Q:'$D(^OR(100,+ORID,0))
143 N PKG
144 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
145 S PKG=$$NMSP^ORCD(PKG)
146 I PKG'="PS" Q
147 N NUMCHDS,NOWID,NOWVAL
148 S (NOWVAL,NOWID)=0
149 S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4)
150 I NUMCHDS>2 S ORY=1 Q
151 I NUMCHDS=2 D
152 . S ORY=1
153 . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
154 . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1))
155 I NOWVAL=1 S ORY=0 Q
156 Q
157ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order
158 Q:'$D(^OR(100,+ORID,0))
159 N PKG,LACT,OELACT,ISNOW
160 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
161 S PKG=$$NMSP^ORCD(PKG)
162 I PKG'="PS" Q
163 N CHLDCNT,IDX,X3
164 S (CHLDCNT,IDX)=0
165 S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4)
166 I 'CHLDCNT Q
167 F S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX D
168 . S (LACT,OELACT,ISNOW)=0
169 . D ISNOW(.ISNOW,IDX)
170 . Q:ISNOW
171 . S X3=$G(^OR(100,IDX,3))
172 . S LACT=$P(X3,U,7)
173 . F S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT
174 . S:OELACT>LACT LACT=OELACT
175 . S ORY(IDX)=IDX_";"_LACT
176 Q
177CANRN(ORY,ORID) ; Check conjunction for renew.
178 ; All conjunctioni = "And" return 1
179 ; Has a "Then" return 0
180 Q:'$G(^OR(100,+ORID,0))
181 N PKG
182 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
183 S PKG=$$NMSP^ORCD(PKG)
184 I PKG'="PS" Q
185 N INDX,INDY,CANRENEW
186 S INDX=0
187 S CANRENEW=1
188 N CHID
189 S CHID=0 F S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID D
190 . N ORSTS,ACTIVE S ORSTS=0
191 . S ORSTS=$P($G(^OR(100,CHID,3)),U,3)
192 . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0))
193 . I ACTIVE'=ORSTS S CANRENEW=0
194 I 'CANRENEW S ORY=CANRENEW Q
195 F S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX D
196 . S INDY=0 F S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY D
197 . . I $G(^(INDY))="T" S CANRENEW=0 Q
198 . I CANRENEW=0 Q
199 S ORY=CANRENEW
200 Q
201ISNOW(ORY,ORID) ; Is first time now order?
202 N SCH
203 Q:'$D(^OR(100,+ORID,0))
204 S SCH=""
205 S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
206 S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1))
207 S:SCH="NOW" ORY=1
208 Q
Note: See TracBrowser for help on using the repository browser.