source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVOPT.m@ 623

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

initial load of WorldVistAEHR

File size: 7.7 KB
Line 
1PSIVOPT ;BIR/PR,MLM-OPTION DRIVER ;06 Aug 98 / 2:17 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**17,27,58,88,104,110,155**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191
5 ; Reference to ^PSDRUG is supported by DBIA# 2192
6 ; Reference to ^PS(52.6 is supported by DBIA# 1231
7 ; Reference to ^PS(52.7 is supported by DBIA# 2173
8 ;
9 NEW PSIVLOCK S PSIVLOCK=0
10 ;I ON["P" L +^PS(53.1,+ON):1 S:'$T PSIVLOCK=1
11 I ON["V" L +^PS(55,DFN,"IV",+ON55):1 S:'$T PSIVLOCK=1
12 I PSIVLOCK W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
13 ;W ! L +^PS(55,DFN,"IV",+ON55):1 I '$T W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
14 I PSIVAC="O"!(PSIVAC="H") S PSIVAC=PSIVAC_"(DFN,ON,P(17),P(3))"
15 S TEX="Active order ***" I $D(UWLFLAG),UWLFLAG="1.001" S XED=0 D @PSIVAC G K
16 S DONE=0 F D ACT Q:DONE
17 ;
18UNLOCK ; Unlock order.
19 ;I ON["P" L -^PS(53.1,+ON)
20 ;E L -^PS(55,DFN,"IV",+ON55)
21 I ON["V" L -^PS(55,DFN,"IV",+ON55)
22 ;
23K ; Kill variables.
24 K %,DA,DIE,DIK,DLAYGO,DNE,DR,DRG,DRGI,DRGT,ERR,HELP,J,OD,P,P16,PSIVAL,PSIVC,PSIVLOG,PSIVNOL,PSIVOK,PSIVOPT,PSIVREA,SCRNPRO,TEX,XED
25 Q
26ACT ; Prompt for order action.
27 K PSJIVBD NEW PSGFDX,PSGSDX S (PSJORD,ON)=ON55
28 S PSJCOM=$S(ON["V":$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",8),1:$P($G(^PS(53.1,+ON,.2)),"^",8))
29 D:ON["V" EN^PSJLIORD(DFN,ON)
30 I ON["P",($P($G(^PS(53.1,+ON,0)),U,9)="N"),'PSJCOM D GT531^PSIVORFA(DFN,ON),VF^PSIVORC2 S DONE=1 Q
31 I ON["P",PSJCOM Q:'$$LOCK^PSJOEA(DFN,PSJCOM) N PSJO,ON,PSJORD S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSJCOM,PSJO)) Q:'PSJO Q:$G(Y)="Q" S (PSJORD,ON)=PSJO_"P" D
32 .D:($P($G(^PS(53.1,+ON,0)),U,9)="N") GT531^PSIVORFA(DFN,ON),VF^PSIVORC2
33 .D:($P($G(^PS(53.1,+ON,0)),U,9)="P") EN^PSJLIFN
34 I $G(PSJCOM) N PSJORD S PSJORD=PSJCOM D CHK^PSJOEA1
35 I ON'["V",'+$G(PSJCOM) D EN^PSJLIFN
36 S DONE=1
37 Q
38 ;
39CK ; Check if drugs are still valid.
40 F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI D
41 .S DRG=+$P(DRG(DRGT,DRGI),U),X=$G(^PS(FIL,DRG,"I")) I $S('X:0,DT<X:0,1:1)!$S('$G(^PSDRUG(+$P($G(^PS(FIL,DRG,0)),U,2),"I")):0,^("I")>DT:0,1:1) S ERR=1
42 Q
43 ;
44D ; Discontinue order.
45 D D^PSIVOPT2
46 Q
47 ;
48O(DFN,ON,STAT,STOP) ; On/Off Call
49 D NOW^%DTC I STAT="H",STOP<% D EXPIR Q
50 I "OA"'[STAT W !,$C(7),"Only active orders may be placed on hold." Q
51 S PSIVALT=1,PSIVREA=$S(STAT'="O":"O",1:"C"),(P(17),STAT)=$S(PSIVREA="O":"O",1:"A") W:PSIVREA="C" ?$X+4,$C(7),TEX
52 D UPSTAT,LOG^PSIVORAL D:STAT="A" CKO^PSIVCHK
53 Q
54 ;
55E ; Entry for Pharmacy edit
56 N PSJEDIT1 D E^PSIVOPT1
57 Q
58 ;
59R ; Renew order.
60 D R^PSIVOPT2
61 Q
62 ;
63H(DFN,ON,STAT,STOP) ; Place order on hold.
64 D NOW^%DTC I STAT="H" I STOP<% D EXPIR Q
65 I "HA"'[STAT W !,$C(7),"Only active orders may be placed on hold." Q
66 D NATURE^PSIVOREN I '$D(P("NAT")) W !!,"Order unchanged." Q
67 S PSIVALT=1,PSIVREA=$S(STAT'="H":"H",1:"U"),(P(17),STAT)=$S(PSIVREA="H":"H",1:"A") W:PSIVREA="U" ?$X+4,$C(7),TEX
68 D UPSTAT,LOG^PSIVORAL,HOLD^PSIVOE,ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(PSIVREA="H":"H1",1:"H0")) D:STAT="A" CKO^PSIVCHK
69 Q
70 ;
71S ; View order.
72 D @$S(ON55["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON55_""")") W @IOF D EN^PSIVORV2
73 Q
74 ;
75EXPIR ; Update status of expired orders.
76 I STAT="H" S PSIVREA="H",P(17)="E"
77 S STAT="E" D UPSTAT,EXPIR^PSIVOE W $C(7)," This order has expired."
78 Q
79 ;
80UPSTAT ; Update orders status.
81 N DA,DR,DIE,PSIVACT S PSIVACT=1,DA=+ON55,DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"",",DR="100///"_P(17)_$S($G(PSIVREA)="H":";149///1",$G(PSIVREA)="U":";149///@",1:"") D ^DIE
82 Q
83 ;
84ENIN ; Entry for inpatient order entry/profile options.
85 N DFN,ON,P,PSIVAC S PSIVAC="C" I PSJORD["P" S (P("PON"),ON)=+PSJORD_"P",DFN=PSGP D SHOW1^PSIVORC Q
86 S (P("PON"),ON,ON55)=+PSJORD_"V",DFN=PSGP D GT55^PSIVORFB,EN^PSIVORV2,PSIVOPT:'$D(PSJPRF)
87 L -^PS(55,DFN,"IV",+PSJORD)
88 Q
89 ;
90ENARI(DFN,ON,PSGUOW,PSIVAL) ; Auto-reinstate IV orders if movement is deleted.
91 ;Create a list of recipients beyond normal mail group
92 S PSGORNUM=$S($G(PSGORD):PSGORD,$G(PSJORD):PSJORD,$G(OR55):OR55,1:"")
93 I $G(PSGORNUM) D
94 .I $D(^PS(55,PSGP,"IV",+PSGORNUM,0)),$P(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6))="" ; Provider
95 .I $D(^PS(55,PSGP,"IV",+PSGORNUM,2)),$P(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11))="" ; Entered by
96 .I $D(^PS(55,PSGP,"IV",+PSGORNUM,4)),$P(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1))="" ; Verifying Nurse
97 ; find pharmacist that finished the IV order
98 N PSJX,ENTBY S PSJX=$G(^PS(55,PSGP,"IV",+ON,"A",1,0))
99 I $P(PSJX,U,2)="F" S ENTBY=$$VA200($P(PSJX,U,3)) I ENTBY'="" S PSJSENTO($J,ENTBY)=""
100 ;
101 I $G(PSGALO)'=18530,$G(PSGORNUM),$$IVDUPADD^PSIVOPT(PSGP,+PSGORNUM) S ^TMP("PSJNOTUNDC",$J,PSGP,+PSGORNUM_"V")="" Q
102 N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVALT,X,Y
103 S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC")
104 S PSIVACT=1,DR=$S(+$P($G(^PS(55,DFN,"IV",+ON,4)),U,18)=1:"100///H",+$P($G(^PS(55,DFN,"IV",+ON,0)),U,10)=1:"100///H",1:"100///A")_";.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";109///@;116///@;121///@"
105 S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
106 N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@"
107 D ^DIE
108 S ^TMP("PSJUNDC",$J,DFN,ON_"V")=""
109 S ON55=ON,P(17)="A",PSIVREA=$S($D(PSJUNDC):"AI",1:"I"),PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U) D LOG^PSIVORAL
110 ;* S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),ORIFN=$P(Y,U,21),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
111 S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
112 .D EN1^PSJHL2(DFN,"SC",+ON55_"V","AUTO REINSTATED")
113 S PSGTOL=$S($D(PSJUNDC):3,1:2)
114 Q:$S('$D(PSJUNDC):0,PSGALO=18540:1,1:'$P($G(PSJSYSW0),U,15))
115 I $D(^PS(53.41,1,1,PSGUOW,1,DFN,1,3,1,+ON)) K DIK,DA S DIK="^PS(53.41,1,1,"_PSGUOW_",1,"_DFN_",1,3,1,",DA=+ON,DA(1)=1,DA(2)=PSGP,DA(3)=PSGUOW,DA(4)=3 D ^DIK
116 E K DA D ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,3,+ON,"RE")
117 Q
118 ;
119ENINP(DFN,ON) ; Entry from Inpatient Profile.
120 N PSIVAC,ON55 S PSIVAC="PRO" D @($S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")")),ENNH^PSIVORV2(ON)
121 Q
122ENLBL(PSGTOL,PSGUOW,PSGP,PSGTOO,DA,RES) ;
123 ;Queue MAR labels for IV orders.
124 Q:'$D(^DPT(PSGP,.1)) I '$D(PSJSYSW0) N PSJACPF,PSJACNWP S PSJACPF=11 D WP^PSJAC Q:'PSJSYSL
125 N P,X,Y
126 S X=$P(PSJSYSW0,U,2),Y=$P($G(^PS(55,PSGP,"IV",DA,0)),U,4)
127 S Y=$S(Y="A":4,Y="H":5,Y="C":6,1:3) I X=1!(X[Y) D NOW^%DTC S PSGDT=% D ENL^PSGVDS S ^PS(55,DFN,"IV",DA,7)=PSGDT_U_RES
128 Q
129 ;
130IVDUPADD(PSGP,ORDERNUM) ;
131 N PSJCOM
132 S DUPLOOP=0
133 S DUPFOUND=0
134 ;Loop through the additives of order to reinstate
135 S PSJCOM=+$P($G(^PS(55,+PSGP,"IV",ORDERNUM,.2)),"^",8) F S DUPLOOP=$O(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP)) Q:((DUPLOOP="")!(DUPFOUND)) D
136 .;Get the additive code no.
137 .S TARGET=$P(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP,0),"^",1)
138 .D NOW^%DTC
139 .S DATELOOP=%
140 .;Loop through the current orders for the patient by date
141 .F S DATELOOP=$O(^PS(55,PSGP,"IV","AIS",DATELOOP)) Q:((DATELOOP="")!(DUPFOUND)) D
142 ..S EXISTORD=""
143 ..;Loop through the orders for date by order number
144 ..F S EXISTORD=$O(^PS(55,PSGP,"IV","AIS",DATELOOP,EXISTORD)) Q:((EXISTORD="")!(DUPFOUND)) D
145 ...;Loop through additives for the existing order
146 ...I PSJCOM>0 Q:+$P($G(^PS(55,+PSGP,"IV",EXISTORD,.2)),"^",8)
147 ...S EXISTADD=0
148 ...F S EXISTADD=$O(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD)) Q:((EXISTADD="")!(DUPFOUND)) D
149 ....;Extract the Additive Code number for the Order
150 ....S MATCHADD=$P(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD,0),"^",1)
151 ....;If the existing order and the order to be reinstated have the same additive code then return FOUND=TRUE
152 ....I MATCHADD=TARGET D
153 .....S DUPFOUND=1
154 Q DUPFOUND
155 ;
156VA200(X) ;Return the IEN for the user.
157 ; X = User name
158 NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
159 I +Y=-1 Q ""
160 Q $P(Y,U)
Note: See TracBrowser for help on using the repository browser.