source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJO1.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1PSJO1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ;15 May 98 / 9:28 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**3,47,56,58,109,110,127,162**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191.
5 ; Reference to ^%DTC is supported by DBIA# 10000.
6 ; Reference to ^%ZOSV is supported by DBIA# 10097.
7 ; Reference to XLFDT is supported by DBIA# 10103.
8 ;
9ECHK ;
10 S C="A",ON=+O_"U",START=$G(^PS(55,PSGP,5,+O,2)),STOP=$P(START,U,4),START=$P(START,U,2) S:PSJOS START=-START
11 I +START>PSGDT,(STOP>PSGDT) G SET
12 S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) SET S ND4=$G(^PS(55,PSGP,5,+O,4)) I ST'="O",SD'<PSGODT,$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)
13 E I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))
14 E Q:PSJOL="S" S C="O"
15 ;
16SET ;
17 I ON["P",($D(PRNTON)!($D(P("PRNTON")))) N PSJOK S PSJOK=$$COMCHK($S($G(P("PRNTON"))]"":P("PRNTON"),$G(PRNTON)]"":PRNTON,1:""),PSJPTYP) Q:'PSJOK
18 NEW DRUGNAME D DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
19 S DN=DRUGNAME(1),SUB=$S(PSJOS:START,1:$E(DN,1,40))
20 I ON["P",$G(P("PRNTON"))]"",$G(PRNTON)=+P("PRNTON") Q
21 I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
22 S ^TMP("PSJ",$J,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),ON)=DN_"^"_$G(NF),PSJOCNT=PSJOCNT+1 Q
23 ;
24IVSET ;Set IV data in ^TMP("PSJ",$J,.
25 N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND
26 I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,9,17 S P(X)=$P(Y,U,X)
27 I ON["V",(P(2)=""),(P(3)="") Q
28 I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q
29 I ON'["V",ND S P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4),P(4)=$P($G(^PS(53.1,+ON,8)),U),P("PRNTON")=$P($G(^PS(53.1,+ON,.2)),U,8)
30 I ON'["V",P("PRNTON")]"" N PSJOK S PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP) Q:'PSJOK
31 D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4))
32 I $G(DRG) S DRGT=$S($G(DRG("AD",1))]"":$P($G(DRG("AD",1)),U,2),1:$P($G(DRG("SOL",1)),U,2)),ORTX=DRGT
33 I $G(ORTX)="",(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
34 ;* I $G(ORTX)=""!(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
35 S:$G(ORTX)="" ORTX="NOT FOUND"
36 ;
37IVSET1 ;
38 ;* S TYP=$S(P(2)=P(3):"O",1:"C"),STAT=$S("ED"[P(17):"O",P(17)="P":"P",1:"A")
39 S TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3)) I TYP'="O" S TYP=$S(ON["P":"z",1:"C")
40 S STAT=$S($G(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
41 I P(17)="P" S STAT="C"_$S($P($G(^PS(53.1,+ON,.2)),U,8)]"":"D",$P($G(^PS(53.1,+ON,.2)),U,4)="S":"A",$P($G(^(0)),U,24)="R":"C",1:"B")
42 I ON["P",$G(P("PRNTON"))]"",PRNTON=+P("PRNTON") Q
43 I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
44 S ^TMP("PSJ",$J,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="^F",PSJOCNT=PSJOCNT+1
45 Q
46 ;
47ENU ; update status field to reflect expired orders, if necessary
48 W !!,"...a few moments, I have some updating to do..."
49ENUNM ;
50 F Q=+PSJPAD:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q!(Q>PSGDT) S UPD=Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $D(^PS(55,PSGP,5,QQ,0)),"DEH"'[$E($P(^(0),"^",9)) D
51 .; naked ref below refers to line above
52 .S $P(^(0),"^",9)="E",ORIFN=$P(^(0),"^",21) D EN1^PSJHL2(PSGP,"SC",QQ_"U")
53 K UPD Q
54 ;
55EN(PSJPTYP) ; enter here
56 ; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
57 N PSJX,PSJY
58 S PSJOL=$G(PSJOL) ; Initialize if no 'View Profile' option selected
59 I PSJOL="L",$D(XRTL) D T0^%ZOSV
60 K ^TMP("PSJ",$J) D NOW^%DTC S PSGDT=+$E(%,1,12),DT=$$DT^XLFDT,PSJOS=$P(PSJSYSP0,"^",11),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1)
61 S PSJOCNT=0 I PSJPTYP>1 F PSJORD=0:0 S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
62 .S PSJX=$G(^PS(55,DFN,"IV",+PSJORD,0))
63 .S PSJY=$P(PSJX,U,17)
64 .I $P(PSJX,U,3)<PSGDT,"AR"[PSJY S $P(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E",PSJY="E",ON=+PSJORD D EXPIR^PSIVOE
65 .I +PSJSYSU=3,('+$P($G(^PS(55,DFN,"IV",+PSJORD,4)),U,4)),($P($G(^(.2)),U,4)="D") S PSJPRI="D"
66 .I $S($G(PSJPRI)="D":1,PSJY="P":0,PSJOL="L":1,1:"DPE"'[PSJY) S ON=+PSJORD_"V" D IVSET K PSJPRI,ON
67 D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,(X1,DT)=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)
68 D ENUNM
69 I PSJPTYP'=2 F ST="C","O","OC","P","R" F SD=+PSJPAD:0 S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD F O=0:0 S O=$O(^PS(55,PSGP,5,"AU",ST,SD,O)) Q:'O D ECHK
70 Q:$D(PSGONNV)
71 ;I PSJPTYP'=2 F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
72 N PRNTON F SD="I","N" S (PRNTON,O)=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
73 ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S O=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
74 N PRNTON S (PRNTON,O)=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
75 I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV
76 Q
77 ;
78NVSET ; Set up orders from 53.1.
79 N ND S ND=$G(^PS(53.1,O,0)) I 'ND D Q
80 .K ^PS(53.1,"AS",SD,PSGP,O)
81 I $P(ND,U,15),$G(PSGP) I PSGP'=$P(ND,U,15) D Q
82 .K ^PS(53.1,"AS",SD,PSGP,O)
83 I $P(ND,U,9)["D" D Q
84 .K ^PS(53.1,"AS",SD,PSGP,O)
85 .N ND2 S ND2=$G(^PS(53.1,O,.2)) I $P(ND2,U,8) K ^PS(53.1,"ACX",$P(ND2,U,8))
86 S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
87 S C=$S(((SD="N")&($P($G(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$P($G(^PS(53.1,O,.2)),U,8)]"":"CD",$P($G(^PS(53.1,O,.2)),U,4)="S":"CA",$P($G(^(0)),U,24)="R":"CC",1:"CB")
88 ;I C="CC" S C=$$CKPC^PSGOU(PSGP,+$P($G(^PS(53.1,O,0)),U,25),O)
89 D SET
90 Q
91 ;
92KILL ;
93 K P,STAT,TYP,ORTX,N,JJ
94 Q
95COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
96 S OK=0
97 I PSJCOM=0 S OK=1 Q OK
98 I PSJCOM="" Q OK
99 I PSJPTYP="" Q OK
100 I '$D(^PS(53.1,"ACX",PSJCOM)) Q OK
101 S OK=1 I PSJPTYP=3 Q OK
102 N PSJON S PSJON=""
103 F S PSJON=$O(^PS(53.1,"ACX",PSJCOM,PSJON)) Q:'PSJON D Q:OK=0
104 .I $P($G(^PS(53.1,PSJON,0)),"^",9)["D" K ^PS(53.1,"ACX",PSJCOM)
105 .I $P($G(^PS(53.1,PSJON,0)),"^",4)'="U",PSJPTYP=1 S OK=0 Q
106 .I $P($G(^PS(53.1,PSJON,0)),"^",4)="U",PSJPTYP=2 S OK=0 Q
107 Q OK
Note: See TracBrowser for help on using the repository browser.