source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJADT0.m@ 1582

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1PSJADT0 ;BIR/CML3,PR,MLM-AUTO DC/HOLD CANCEL ;11 Aug 98 / 8:25 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**17,111,112,135**;16 DEC 97
3 ;
4 ;Reference to ^PS(55 supported by DBIA #2191.
5 ;Reference to ^PS(59.7 supported by DBIA #2181.
6 ;
7ENDC ; dc active orders first, then non-verified orders
8 W:'$D(PSJQUIET)&'$D(DGQUIET) !,"...discontinuing Inpatient Medication orders..."
9 S $P(PSJPIND,"^")=""
10 D NOW^%DTC N PSJDCDT S (PSJDCDT,PSGDT)=+%,PSJSYSW0="" I PSJFW S PSJSYSW=$O(^PS(59.6,"B",PSJFW,0)) S:PSJSYSW PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
11 I PSGALO=1010!(PSGALO=1030)!(PSGALO=1050) D AUDDD
12 D ENUNM^PSGOU S PSGALR=10,DIE="^PS(55,"_PSGP_",5," S:PSJFW PSGTOL=1,PSGUOW=PSJFW,PSGTOO=1
13 F PSJS=PSGDT:0 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJS)) Q:'PSJS F PSJDA=0:0 S PSJDA=$O(^PS(55,PSGP,5,"AUS",PSJS,PSJDA)) Q:'PSJDA D
14 .Q:'$$DCIMO(PSGP,PSJDA,"U")
15 .;first naked reference below refers to the full global reference to the right of the = sign (inside the $S)
16 .K DA S DA(1)=PSGP,DA=PSJDA,PSGAL("C")=0,$P(^(2),"^",3)=$S($D(^PS(55,PSGP,5,DA,2)):$P(^(2),"^",4),1:"")
17 .D ^PSGAL5
18 .K TMP
19 .S TMP(55.06,""_PSJDA_","_PSGP_","_"",28)="D"
20 .D FILE^DIE("","TMP")
21 .K TMP
22 .S TMP(55.06,""_PSJDA_","_PSGP_","_"",34)=PSJDCDT
23 .S TMP(55.06,""_PSJDA_","_PSGP_","_"",49)=1
24 .D FILE^DIE("","TMP")
25 .K TMP
26 .D EN1^PSJHL2(PSGP,"OD",PSJDA_"U","AUTO DC")
27 .I PSGALO'=1050 S DA=PSJDA,^PS(55,"AUE",PSGP,DA)="" I $P(PSJSYSW0,"^",15),(PSGALO'<1060) S $P(^PS(55,PSGP,5,PSJDA,7),"^",1,2)=PSJDCDT_"^D" D ENL^PSGVDS
28 S PSGTOO=2 F PSJDA=0:0 S PSJDA=$O(^PS(53.1,"AC",PSGP,PSJDA)) Q:'PSJDA D
29 .Q:'$$DCIMO(PSGP,PSJDA,"P")
30 .I PSGALO'<1060,$P(PSJSYSW0,U,15),$P($G(^PS(53.1,PSJDA,0)),U,9)="N" K DA D ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,2,+PSJDA,"AD")
31 .K DA S DA=PSJDA D I $P($G(^PS(53.1,DA,0)),"^",21) D EN1^PSJHL2(PSGP,"OC",PSJDA_"P","AUTO DC")
32 ..K TMP
33 ..S TMP(53.1,""_PSJDA_","_"",28)="D"
34 ..S TMP(53.1,""_PSJDA_","_"",42)=1
35 ..D FILE^DIE("","TMP")
36 ..K TMP
37 ;
38ENIV ;
39 S DFN=PSGP F PSJIVON=0:0 S PSJIVON=$O(^PS(55,DFN,"IV",PSJIVON)) Q:'PSJIVON S Y=$G(^(PSJIVON,0)) I "PDEN"'[$P(Y,U,17) S P(17)=$P(Y,U,17),P(3)=$P(Y,U,3) D DC
40 Q
41DC ;
42 Q:'$$DCIMO(DFN,PSJIVON,"V")
43 S (ON,ON55)=PSJIVON_"V" D NOW^%DTC I P(17)="H",P(3)<% D D EXPIR^PSIVOE Q
44 .K TMP
45 .S TMP(55.01,""_+ON_","_DFN_","_"",100)="E"
46 .D FILE^DIE("","TMP")
47 .K TMP
48 K PSIVALT S PSIVAC="AD",PSIVALCK="STOP",PSIVREA="D",PSIVAL=$S('+$G(PSGALO):$G(PSIVRES),1:$P($G(^PS(53.3,+PSGALO,0)),U)) D D1^PSIVOPT2,LOG^PSIVORAL
49 K TMP
50 S TMP(55.01,""_+ON_","_DFN_","_"",.03)=PSJDCDT
51 S TMP(55.01,""_+ON_","_DFN_","_"",121)=1
52 D FILE^DIE("","TMP")
53 K TMP
54 D EN1^PSJHL2(DFN,"OD",+ON_"V","AUTO DC")
55 S PSJIVDCF=1
56 Q
57 ;
58SIVDIE ; Setup DIE,DA for IV
59 K DA,DIE,DR S DA=+ON,DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"","
60 Q
61 ;
62AUDDD ; set up orders for discharge report and purging
63 S DIS=+VAIP(17,1) I $S('DIS:1,1:$D(^PS(55,"AUDDD",DIS,PSGP))) Q
64 S X=$$EN^PSGCT(+VAIP(13,1),-1)
65 F Q=X:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $S($D(^PS(55,PSGP,5,QQ,0)):'$P(^(0),"^",20),1:1) S $P(^(0),"^",20)=DIS,^PS(55,"AUDDD",DIS,PSGP,QQ)=""
66 Q
67 ;
68ENHE ; status from hold to expired
69 D NOW^%DTC S PSGDT=+$E(%,1,12),DIE="^PS(55,"_PSGP_",5,"
70 F PSJS=+PSJPAD:0 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJS)) Q:'PSJS Q:PSJS>PSGDT F PSJDA=0:0 S PSJDA=$O(^PS(55,PSGP,5,"AUS",PSJS,PSJDA)) Q:'PSJDA K DA S DA(1)=PSGP,DA=PSJDA I $D(^PS(55,PSGP,5,DA,0)),$P(^(0),"^",9)="H" S DR="28////E" D ^DIE
71 Q
72 ;
73ENUNDC(PSJDCDT,PSGP,PSJUOW,PSGALO) ; Auto-reinstate orders DC'ed due to a patient movement.
74 N PSJSYSW0 D NOW^%DTC S PSJUNDC=1,PSGDT=%,PSJFIRST='$D(PSJQUIET),PSJSYSW0=$G(^PS(59.6,+$O(^PS(59.6,"B",+PSJUOW,0)),0))
75 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJDCDT-.0002)) F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",+PSJS,PSGORD)) Q:'PSGORD D
76 .I $P($G(^PS(55,PSGP,5,PSGORD,0)),U,9)["D",$P($G(^(4)),U,11) D DISREIN,ENRI^PSGOERI
77 .S ^PS(55,"AUE",PSGP,PSGORD)=""
78 ;
79 S:PSJS="" PSJS=$O(^PS(55,PSGP,"IV","AIS",PSJDCDT-.0002))
80 F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,"IV","AIS",+PSJS,PSGORD)) Q:'PSGORD D
81 .I $P($G(^PS(55,PSGP,"IV",PSGORD,0)),U,12),$P($G(^(2)),U,7)>PSGDT S P(3)=$P($G(^(0)),U,3) D DISREIN,ENARI^PSIVOPT(PSGP,PSGORD,+PSJUOW,PSGALO)
82 I $D(^TMP("PSJUNDC")) S ^TMP("PSJUNDC",$J,DFN)=$P(^DPT(DFN,0),"^")_"^"_$G(^DPT(PSGP,.1))_"^"_PSGALO D ^PSJADT2
83 ;
84ENKL ;
85 F UW=0:0 S UW=$O(^PS(53.41,1,1,UW)) Q:'UW D I '$O(^PS(53.41,1,1,0)) K DA S DA=1,DIK="^PS(53.41," D ^DIK
86 .F PSGP=0:0 S PSGP=$O(^PS(53.41,1,1,UW,1,PSGP)) Q:'PSGP D I '$O(^PS(53.41,1,1,UW,1,0)) K DA S DIK="^PS(53.41,1,1,",DA(1)=1,DA=UW D ^DIK
87 ..F TO=0:0 S TO=$O(^PS(53.41,1,1,UW,1,PSGP,1,TO)) Q:'TO D I '$O(^PS(53.41,1,1,UW,1,PSGP,1,0)) K DA S DA(2)=1,DA(1)=UW,DA=PSGP,DIK="^PS(53.41,1,1,"_UW_",1," D ^DIK
88 ...I '$O(^PS(53.41,1,1,UW,1,PSGP,1,TO,1,0)) K DA S DA(3)=1,DA(2)=UW,DA(1)=PSGP,DA=TO,DIK="^PS(53.41,1,1,"_UW_",1,"_PSGP_",1," D ^DIK
89 K DA,DIK,P,PSGDT,PSGP,PSGORD,PSJS,PSJUNDC,TO,UW
90 Q
91 ;
92DISREIN ; Display reinstate msg. for first order.
93 W:PSJFIRST&'$D(DGQUIET) !,"...reinstating Inpatient Medication orders..." S PSJFIRST=0
94 Q
95 ;
96DCIMO(DFN,ON,TYP) ; Check parameter before DC'ing clinic order
97 N GLO,IMOND,A,CLINIC,APPT,B,C S GLO=$S(TYP="P":"^PS(53.1,",TYP="U":"^PS(55,"_DFN_",5,",TYP="V":"^PS(55,"_PSGP_",""IV"",",1:"") I TYP="" Q 1
98 S IMOND=$S(TYP="P"!(TYP="V"):"""DSS""",TYP="U":8,1:"") I IMOND="" Q 1
99 S GLO=GLO_+ON_","_IMOND_")",A=$G(@GLO),CLINIC=$P(A,"^"),APPT=$P(A,"^",2)
100 Q:'$$CLINIC^PSJBCMA(A) 1
101 I '$D(^PS(53.46,"B",CLINIC)) Q 1
102 S B=$O(^PS(53.46,"B",CLINIC,"")),C=+$P(^PS(53.46,B,0),"^",3) Q C
Note: See TracBrowser for help on using the repository browser.