source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJCOMR.m@ 1147

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

initial load of WorldVistAEHR

File size: 9.6 KB
Line 
1PSJCOMR ;BIR/CML3-RENEW A COMPLEX ORDER SERIES ;07 MAR 96 / 1:23 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**110,127,136,157**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 supported by DBIA 2191.
5 ; Reference to ^PSSLOCK is supported by DBIA 2789.
6 ; Reference to NOW^%DTC is supported by DBIA 10000.
7 ; Reference to ^DIR is supported by DBIA 10026.
8 ;
9 ; renew a complex order series
10 Q:'PSJCOM K COMQUIT
11 W !!,"This order is part of a complex order. If you "_$S($P(PSJSYSP0,"^",3):"RENEW",1:"MARK")_" this order the",!,"following orders will be "_$S($P(PSJSYSP0,"^",3):"RENEWED",1:"MARKED")_" too." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
12 W !! K DIR S DIR(0)="Y",DIR("A")=$S($P(PSJSYSP0,"^",3):"RENEW THIS COMPLEX ORDER SERIES",1:"MARK THIS COMPLEX ORDER SERIES FOR RENEWAL"),DIR("B")="YES"
13 S DIR("?")="Answer 'YES' to "_$S($P(PSJSYSP0,"^",3):"renew this complex order series",1:"mark this complex order series for renewal")_". Answer 'NO' (or '^') to stop now." D ^DIR K DIR
14 I 'Y N DIR D ABORT G DONE
15 I '$D(DIRUT),Y D NEW S PSGCANFL=1 D DONE Q
16 I '$D(DIRUT),PSJSYSU I $P(PSGND4,"^",15),$P(PSGND4,"^",16) D UNMARK,DONE Q
17 D DONE,ABORT^PSGOEE
18 Q
19 ;
20UNMARK ;
21 W !!,"THIS COMPLEX ORDER SERIES HAS BEEN 'MARKED FOR RENEWAL'.",! K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO 'UNMARK IT'",DIR("B")="NO"
22 S DIR("?",1)=" Answer 'YES' to unmark this complex order series. Answer 'NO' (or '^') to leave the complex",DIR("?")="order series marked. (An answer is required.)" D ^DIR
23 I 'Y N DIR D ABORT^PSGOEE G DONE
24 N PSGORD,XX,X S XX=0,X="" F S XX=$O(^PS(55,"ACX",PSJCOM,XX)) Q:'XX F S X=$O(^PS(55,"ACX",PSJCOM,XX,X)) Q:X="" S PSGORD=X D
25 .S PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4))
26 .S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=21180+PSJSYSU D ^PSGAL5 S $P(PSGND4,"^",15,17)="^^",^PS(55,PSGP,5,DA,4)=PSGND4 W "...DONE!"
27 ;
28DONE ;
29 K %DT,DA,DIE,DIR,DR,FDSD,PSGAL,PSGALR,PSGDL,PSGDLS,PSGFD,PSGFOK,PSGND4,PSGOEE,PSGOER0,PSGOER1,PSGOER2,PSGOERDP,PSGOPR,PSGOSD,PSGPOSA,PSGPOSD,PSGPR,PSGPX,PSGRD,PSGSD,PSGTOL,PSGTOO,PSGUOW,PSGWLL,RF Q
30 ;
31NEW ; get info, write record
32 K ^TMP("PSJCOMR",$J)
33 N DUOUT,PSGORD,TMPP,TMPO,PS55ACX,TMPDUZ,TMPOE,COMQUIT S TMPP=0 K PS55ACX M PS55ACX(55,"ACX",PSJCOM)=^PS(55,"ACX",PSJCOM)
34 F S TMPP=$O(PS55ACX(55,"ACX",PSJCOM,TMPP)) Q:'TMPP!$G(COMQUIT) D
35 . S TMPO=0 F S TMPO=$O(PS55ACX(55,"ACX",PSJCOM,TMPP,TMPO)) Q:TMPO=""!$G(COMQUIT) S PSGORD=TMPO D:PSGORD["U" NEWUD I PSGORD["V" D NEWIV
36 I $G(COMQUIT)!$G(DUOUT) W !!,"By not verifying all the orders, none of the orders will be verified." D PAUSE^VALM1 Q
37 I '$G(COMQUIT)&'$G(DUOUT) S TMPOE=0 F S TMPOE=$O(^PS(55,"ACX",PSJCOM,TMPOE)) Q:TMPOE="" S TMPO=0 F S TMPO=$O(^PS(55,"ACX",PSJCOM,TMPOE,TMPO)) Q:'TMPO!$G(COMQUIT) S PSGORD=TMPO D
38 . K VSTRING S VSTRING=$G(^TMP("PSJCOMR",$J,PSJCOM,TMPO)) I PSGORD'=$P(VSTRING,"^",2) S COMQUIT=1 Q
39 . S PSGP=$P(VSTRING,"^"),PSGDT=$P(VSTRING,"^",3),PSGOEPR=$P(VSTRING,"^",4),PSGOFD=$P(VSTRING,"^",5),PSGFD=$P(VSTRING,"^",6),PSJNOO=$P(VSTRING,"^",7),TMPDUZ=$P(VSTRING,"^",8)
40 . D:PSGORD["U" FILEUD D:PSGORD["V" FILEIV
41 K ^TMP("PSJCOMR",$J),VSTRING
42 Q
43NEWUD N PSJABT,PSGDRG,PSJREN,X,XX,PSGORDP,UDSTRING S PSGDRG=$P($G(^PS(55,PSGP,5,+PSGORD,1,1,0)),"^"),PSJREN=1
44 D OC55
45 Q:$D(PSGORQF) ; quit if not to continue
46 D NOW^%DTC S PSGDT=%,PSGND4=$G(^PS(55,PSGP,5,+PSGORD,4)) I '$P(PSJSYSP0,"^",3) D MARK Q
47 S PSGWLL=$S('$P(PSJSYSW0,"^",4):0,1:+$G(^PS(55,PSGP,5.1))),PSGOEE="R" K PSGOEOS
48 K ^PS(53.45,PSJSYSP,1),^(2) D MOVE(3,1),MOVE(1,2)
49 D DATE^PSGOER0(PSGP,PSGORD,PSGDT) I '$D(PSGFOK(106)) D DONE,ABORT^PSGOEE S VALMBCK="R" Q
50 W !!,"...updating order..." N PSGOEAV S PSGOEAV=+PSJSYSU,PSGOORD=PSGORD,PSGOER1=$G(^PS(55,PSGP,5,+PSGORD,.2)),PSGSI=$G(^(6)) W "."
51 S PSGMR=$P(PSGOER0,"^",3),PSGSM=$P(PSGOER0,"^",5),PSGHSM=$P(PSGOER0,"^",6)
52 S PSGMRN=$$ENMRN^PSGMI(PSGMR),PSGPDRGN=$$ENPDN^PSGMI(PSGPDRG),PSGDO=$P(PSGOER1,"^",2),PSGSCH=$P(PSGOER2,"^")
53 S PSGS0Y=$P(PSGOER2,"^",5),PSGS0XT=$P(PSGOER2,"^",6),PSGNESD=PSGSD,PSGNEFD=PSGFD
54 S:PSJPWD'=$P(PSGOER2,U,10) PSGS0Y=$$ENRNAT^PSGOU($P(PSGOER2,U,10),+PSJPWD,PSGSCH,PSGS0Y)
55 S UDSTRING=PSGP_"^"_PSGORD_"^"_PSGDT_"^"_PSGOEPR_"^"_PSGOFD_"^"_PSGFD_"^"_PSJNOO F II=1:1:$L(UDSTRING,"^") I $P(UDSTRING,"^",II)="" K UDSTRING
56 I '$D(UDSTRING) S COMQUIT=1 Q
57 S:$G(DUZ) UDSTRING=UDSTRING_"^"_DUZ D TEMP(UDSTRING)
58 Q
59 ;
60FILEUD ;
61 ;Changed the reference to the type "O" for order numbers previously in v4.5
62 N X,PSJORD,PSGOERDP,PSGOREAS,PSGRZERO S PSJORD=PSGORD K PSJPREX
63 ;Make sure Admin times for parent don't carry to children;BHW;PSJ*5*136
64 S X=$$LS^PSSLOCK(PSGP,PSGORD) S PSGRTWO=^PS(55,+$G(PSGP),5,+PSGORD,2) S PSGRZERO="^PS(55,"_PSGP_",5,"_+PSGORD_",0)",PSGOREAS=$P(@(PSGRZERO),"^",24) D
65 . S (PSGAT,PSGS0Y)=$P(PSGRTWO,"^",5)
66 . S $P(@PSGRZERO,"^",24)="R" D UPDREN^PSGOER(PSGORD,PSGDT,PSGOEPR,PSGOFD,PSJNOO,$G(TMPDUZ)),UPDRENOE^PSGOER(PSGP,PSGORD) S $P(@PSGRZERO,"^",24)=PSGOREAS
67 I +$G(PSJSYSU)=3,$G(PSJCOM) D CMPLX2^PSJCOM1(PSGP,PSJCOM,PSGORD) I $G(PSGPXN) S PSJPREX=1
68 W !!,"...updating order..." K DA S DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=PSJSYSU*10+18000 D ^PSGAL5 W "."
69 I '$G(PSGOERDP),$P(PSJSYSW0,"^",4) I $G(PSGFD),$G(PSGWLL),(PSGFD'<PSGWLL) S $P(^PS(55,PSGP,5.1),"^")=+PSGFD
70 D UNL^PSSLOCK(PSGP,PSGORD)
71 W ".DONE!" S VALMBCK="Q"
72 Q
73 ;
74MARK ;
75 I $P(PSGND4,"^",15),$P(PSGND4,"^",16) W $C(7),!!?3,"...THIS ORDER IS ALREADY MARKED FOR RENEWAL!..." Q
76 K DA S $P(PSGND4,"^",15,17)="1^"_DUZ_"^"_PSGDT,^PS(55,PSGP,5,+PSGORD,4)=PSGND4,PSGAL("C")=13180,DA(1)=PSGP,DA=+PSGORD W "." D ^PSGAL5
77 I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="R",PSGPOSD=PSGDT D ENPOS^PSGVDS
78 Q
79MOVE(X,Y) ; Move comments/dispense drugs from 55 to 53.45.
80 S Q=0 F S Q=$O(^PS(55,PSGP,5,+PSGORD,X,Q)) Q:'Q S ^PS(53.45,PSJSYSP,Y,Q,0)=$G(^(Q,0))
81 S:Q ^PS(53.45,Y,0)="^53.450"_Y_"P^"_Q_U_Q
82 Q
83OC55 ;* Order checks for Speed finish and regular finish
84 N INTERVEN,PSJDDI,PSJIREQ,PSJRXREQ,PSJPDRG
85 S Y=1,(PSJIREQ,PSJRXREQ,INTERVEN,X)=""
86 K PSGORQF D ENDDC^PSGSICHK(PSGP,+$G(^PS(55,PSGP,5,+PSGORD,1,1,0)))
87 I '$D(PSGORQF) K PSGORQF,^TMP($J,"DI") D
88 . F PSGDDI=1:0 S PSGDDI=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDDI)) Q:'PSGDDI S PSJDD=+$G(^PS(55,PSGP,5,+PSGORD,1,PSGDDI,0)) K PSJPDRG D IVSOL^PSGSICHK
89 Q
90 ;
91RIV ; Renew order.
92 Q:'PSJCOM N PSGORD,TMPP,TMPO S (TMPP,TMPO)=0 K PS55ACX M PS55ACX(55,"ACX",PSJCOM)=^PS(55,"ACX",PSJCOM)
93 F S TMPP=$O(PS55ACX(55,"ACX",PSJCOM,TMPP)) Q:'TMPP S TMPO=0 F S TMPO=$O(PS55ACX(55,"ACX",PSJCOM,TMPP,TMPO)) Q:TMPO="" D
94 . S PSGORD=TMPO D:PSGORD["U" NEWUD D:PSGORD["V" NEWIV
95 Q
96NEWIV ;Renew complex IV orders
97 N X,XX
98 I P(17)="D",P(12) N ERR D RI W:$G(ERR)=1 $C(7)," Order unchanged." Q:$G(ERR)<2
99 NEW PSGORQF S PSIVRNFG=1 D ORDCHK^PSJLIFN K PSIVRNFG Q:$G(PSGORQF) W !
100 I $G(PSGORD)["V" S ON55=PSGORD S P("OLDON")=$P(^PS(55,DFN,"IV",+PSGORD,2),"^",5) S:'P("OLDON") P("OLDON")=ON55
101 ;
102R1 N PSIVND0,PSIVND2,PSIVREAS,PSIVOFD,IVSTRING,P2,PSJBKDR S PSJBKDR=1
103 S P("NEWON")=ON55,(PSIVOK,EDIT)="25^1",P2=P(2) S P(2)=$$DATE^PSJUTL2 D EDIT^PSIVEDT S P(2)=P2 I X="^" D RD Q
104 S:+VAIN(4)'=$P($G(^PS(55,DFN,"IV",+P("OLDON"),2)),U,10) P(11)=$$ENRNAT^PSGOU($P($G(^PS(55,DFN,"IV",+P("OLDON"),2)),U,10),+VAIN(4),P(9),P(11))
105 S PSIVCHG=2
106 D OK G:X["N" R1 I X=U D RD Q
107 S P(17)="A",P("RES")="R",P("FRES")="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D Q:'$D(P("NAT"))
108 .D NATURE^PSIVOREN I '$D(P("NAT")) D RD S COMQUIT=1 Q
109 .S ON=ON55 ;D SET^PSIVORFE
110 S P(16)="",PSJORIFN="",PSIVACT=1,P("21FLG")="",PSIVOFD=$P($G(^PS(55,DFN,"IV",+PSGORD,0)),"^",3)
111 S IVSTRING=DFN_"^"_ON55_"^"_$$DATE^PSJUTL2()_"^"_+$G(P(6))_"^"_PSIVOFD_"^"_P(3)_"^"_P("NAT") F II=1:1:$L(IVSTRING,"^") I $P(IVSTRING,"^",II)="" K IVSTRING
112 I '$D(IVSTRING) S COMQUIT=1 Q
113 S:$G(DUZ) IVSTRING=IVSTRING_"^"_DUZ D TEMP(IVSTRING)
114 Q
115 ;
116FILEIV ;
117 N X,ON,ON55,PSJORD,P,PSIVTMP,PSIVZERO,OREAS
118 S X=$$LS^PSSLOCK(DFN,+PSGORD_"V") S PSIVZERO="^PS(55,"_DFN_",""IV"","_+PSGORD_",0)" S PSIVTMP0=$G(@PSIVZERO) Q:'PSIVTMP0
119 S PSIVTMP2="^PS(55,"_DFN_",""IV"","_+PSGORD_",2)",OREAS=$P(PSIVTMP2,"^",8),$P(@PSIVTMP2,"^",8)="R"
120 F I=1:1:$L(PSIVTMP0,"^") S P(I)=$P(PSIVTMP0,"^",I)
121 S (ON,ON55,PSJORD)=PSGORD,P(3)=PSGFD,P(6)=PSGOEPR,P("NAT")=PSJNOO,PSIVOFD=PSGOFD D RUPDATE^PSIVOREN(DFN,ON55,P(2))
122 Q:'PSJIVORF
123 D EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED")
124 S OD=P(2) D EN^PSIVORE
125 D VF1^PSJLIACT("","",0),UNL^PSSLOCK(DFN,+ON55_"V") S $P(@PSIVTMP2,"^",8)=OREAS
126 D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
127 Q
128 ;
129TEMP(VARS) ;
130 Q:'PSJCOM S ^TMP("PSJCOMR",$J,PSJCOM,PSGORD)=VARS
131 Q
132 ;
133RD ; Delete for renew.
134 D DEL55^PSIVORE2 S (ON55,P("PON"))=P("OLDON") D GT55^PSIVORFB
135 Q
136 ;
137OK ;Print example label, run order through checker, ask if it is ok.
138 S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) I ($G(P("PD"))="") D GTPD^PSIVORE2
139 D ^PSIVCHK I $D(DUOUT) S X="^" Q
140 I ERR=1 S X="N" Q
141 W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
142 D EFDIV^PSJUTL($G(ZZND))
143 S X="Is this O.K.: ^"_$S(ERR:"N",1:"Y")_"^^NO"_$S(ERR'=1:",YES",1:"") D ENQ^PSIV I X["?" S HELP="OK" D ^PSIVHLP G OK
144 Q
145 ;
146RI ; Reinstate Auto-DC'ed order.
147 N DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA W !!,$C(7),"This order has been Auto-DC'ed."
148 S DIR(0)="Y",DIR("A")="Reinstate this order" D ^DIR K DIR I 'Y S ERR=1 Q
149 D NOW^%DTC I %>$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) D
150 .K DIR S ERR=1,DIR(0)="Y",DIR("A",1)="The original stop date of this order has past.",DIR("A")="Do you wish to renew this order" D ^DIR K DIR S ERR=$S(Y:2,1:1)
151 Q:$G(ERR) S X=$G(^VA(200,+P(6),"PS")) I $S('X:1,'$P(X,U,4):0,DT<$P(X,U,4):0,1:1) S ERR=1
152 I $G(ERR) W !!,$C(7),"This order's provider is no longer valid. Please enter a valid provider." S (EDIT,PSIVOK)=1 D EDIT^PSIVEDT I $G(DONE) W $C(7),"Order unchanged." S ERR=1 Q
153 N PSGALO S PSGALO=18530 D ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
154 Q
155 ;
156ABORT ; No changes
157 W !!,$C(7),"No changes made to this order." D PAUSE^VALM1 K PSGOEEF S PSGOEEF=0
158 Q
Note: See TracBrowser for help on using the repository browser.