source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJH1.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: 3.6 KB
Line 
1PSJH1 ;BIR/CML3,PR-GET UNIT DOSE/IV ORDERS FOR INPATIENT ;09 DEC 97 / 8:38 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**35,47,58,85,174**;16 DEC 97
3 ;
4 ;Reference to ^PS(50.7 is supported by DBIA 2180
5 ;Reference to ^PS(55 is supported by DBIA 2191
6 ;Reference to ^%DTC is supported by DBIA 10000
7 ;Reference to ^%ZOSV is supported by DBIA 10097
8 ;Reference to ^XLFDT is supported by DBIA 10103
9 ;
10ECHK ;
11 S C="A",DRG=$P($G(^PS(55,PSGP,5,+O,.2)),"^") S:PSJOS START=-$P($G(^(2)),"^",2)
12 S O=O_"U"
13 G:SD>PSGDT SET S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) SET S ND4=$G(^(4)) I ST'="O",SD'<PSGODT,$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)
14 E I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))
15 E Q:PSJOL="S" S C="O"
16 ;
17SET ;
18 S DN=$S(DRG="":"NOT FOUND",'$D(^PS(50.7,DRG,0)):"NOT FOUND ("_DRG_")",$P(^(0),"^")]"":$P(^(0),"^"),1:DRG_";PS(50.7,"),NF=$P(DN,"^",9),SUB=$S(PSJOS:START,1:$E(DN,1,50))
19 S ^TMP("PSJ",$J,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),O)=DN_"^"_NF,PSJOCNT=PSJOCNT+1 Q
20 ;
21IVSET ; Set IV data in ^TMP("PSJ",$J,.
22 N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,ND
23 I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)) Q:$D(PSJHDATE)&($P(Y,"^",2)<PSJHDATE) F X=2,3,4,9,17 S P(X)=$P(Y,U,X)
24 I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q
25 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)
26 G:PSJOS IVSET1 I P(4)="H" S ORTX="* TPN *" G IVSET1
27 I P(4)="A" D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4)) I $E(P("OT"))="F" S DRGT=$O(DRG(0)),Y=$O(DRG(DRGT,0)),ORTX=$P(DRG(DRGT,Y),U,2) G IVSET1
28 S ORTX=$$ENPDN^PSGMI(+$S(ON["V":$G(^PS(55,DFN,"IV",+ON,6)),1:$G(^PS(53.1,+ON,.1))))
29 ;
30IVSET1 ;
31 S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
32 S STAT=$S("ED"[P(17):"O",P(17)="P":"NZ",1:"A"),^TMP("PSJ",$J,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="",PSJOCNT=PSJOCNT+1
33 Q
34 ;
35ENU ; update status field to reflect expired orders, if necessary
36 W !!,"...a few moments, I have some updating to do..."
37ENUNM ;
38 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)) S $P(^(0),"^",9)="E"
39 K UPD Q
40 ;
41EN ; enter here
42 I PSJOL="L",$D(XRTL) D T0^%ZOSV
43 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) S:'$D(PSJHDATE) PSJHDATE=0
44 S PSJOCNT=0 F PSJORD=0:0 S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
45 .S X=$G(^PS(55,DFN,"IV",+PSJORD,0))
46 .S Y=$P(X,U,17)
47 .S ON=+PSJORD_"V" D IVSET
48 D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,X1=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)
49 F ST="C","O","OC","P","R" F SD=+PSJHDATE: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
50 Q:$D(PSGONNV)
51 F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O D NVSET
52 ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S SD="P",O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")
53 S SD="P",O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P" D @$S($P($G(^PS(53.1,O,0)),U,4)="F":"IVSET",1:"NVSET")
54 I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV
55 Q
56 ;
57NVSET ; Set up orders from 53.1.
58 N ND,OSAVE,PORD S ND=$G(^PS(53.1,O,0)) I 'ND D Q
59 .K ^PS(53.1,"AS",SD,PSGP,O)
60 S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),DRG=$P($G(^(.2)),U),C="N"_$TR(SD,"NIP","XYZ") S:ST="" ST="z"
61 S PORD=$P($G(^PS(53.1,O,.2)),U,8),OSAVE=O,O=$S(PORD:PORD,1:O_"P") D SET S O=+OSAVE
62 Q
63 ;
64KILL ;
65 K P,STAT,TYP,ORTX,N,JJ
66 Q
Note: See TracBrowser for help on using the repository browser.