source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXR.m@ 1720

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

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