source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJO.m@ 1487

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

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1PSJO ;BIR/CML3,PR-GET AND PRINT INPATIENT ORDERS ;28 Jun 99 / 10:20 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**31,58,110**;16 DEC 97
3 ;
4 ; Reference to ^PSD(58.8 supported by DBIA #2283.
5 ; Reference to ^PSI(58.1 supported by DBIA #2284.
6 ; Reference to ^PS(55 supported by DBIA #2191.
7 ;
8 K ^TMP("PSJON",$J),^TMP("PSJ",$J) D @$S($D(PSJEXTP):"EN^PSJH1",1:"EN^PSJO1(3)")
9 S PSJDEV=IO'=IO(0)!($E(IOST,1,2)'="C-"),(NP,PSGON,PSJON)=""
10 U IO D ENGET^PSJO3 I '$D(^TMP("PSJ",$J)) W !,SLS,SLS,$E(SLS,1,25),!!?22,"NO ORDERS FOUND FOR ",$S(PSJOL="S":"SHORT",1:"LONG")," PROFILE."
11 E S (PSJC,PSJS,PSJO,PSJST)="" F S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC="" D G:NP["^" DONE
12 .D:$S((PSJC["B"&'TF):0,PSJC'["A":1,1:1) TF
13 .F S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST="" F S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS=""!(NP[U) D ON
14 G:NP[U DONE I PSJDEV,$S('$D(PSJPRP):1,1:PSJPRP="P") D BOT
15 ;
16DONE ;
17 I $S('$D(PSJPRP):1,1:PSJPRP="P") K ^TMP("PSJ",$J)
18 S PSGON=PSJON K:'$D(PSGVBW) PSGODT K %,%H,%I,C,DN,DO,DRG,FQ,GIVE,HDT,I,JJ,LN2,N,ND,ND4,ND6,NF,NP,O,ON,ORIFN,ORTX,P,PF,PG,PS,PSGID,PSGOD,PSIVSC,PSIVST,PSIVTY,PSJC,PSJDEV,PSJF,PSJO,PSJOS,PSJS,PSJSCHT,PSJST,QQ,RB,RTE,SCH,SD,SLS,SM
19 K ST,START,STAT,SUB,TF,TYP,UDU,UPD,V,WS,X,X1,X2,Y Q
20 ;
21ON ;
22 S PSJSCHT=$S(PSJOS:PSJS,1:PSJST)
23 F FQ=0:0 S PSJO=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS,PSJO)) Q:PSJO="" S DN=^(PSJO) D:$Y+6>IOSL ENNP^PSJO3 Q:NP["^" D ;
24 .S PSJON=PSJON+1 S:'PSJDEV ^TMP("PSJON",$J,PSJON)=PSJO W !,$J(PSJON,4),?5 D @$S(PSJO["V":"PIV^PSIVUTL(PSJO)",PSJO["U":"PUD",1:"PIV^PSIVUTL(PSJO)")
25 Q
26 ;
27PUD ; print unit dose
28 ; Naked reference below refers to full reference ^PS(53.1,+PSJO,0) or ^PS(55,DFN,5,+PSJO,0) using indirection.
29 S ND=$S($D(@(PSJF_+PSJO_",0)")):^(0),1:""),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$P($G(^(6)),"^"),DO=$S($P(DN,"^",2)=.2:$P($G(@(PSJF_+PSJO_",.2)")),"^",2),1:$G(@(PSJF_+PSJO_",.3)")))
30 ;I PSJC["A" S V='$P(ND4,"^",UDU) W $S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" ") W:V&(PSJSYSU) "->"
31 I "AO"[PSJC D
32 .S V='$P(ND4,"^",UDU),V=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
33 .W $S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" ")
34 .W $S($P($G(@(PSJF_+PSJO_",.2)")),"^",4)="D":"d",1:" ")_$S(V:"->",1:" ")
35 ;I $S(PSJC["NZ":0,1:PSJC["N") W $S($P(ND4,"^",12):"D",1:" "),$S(PSJSYSU:"->",1:"")
36 I $S(PSJC["NZ":0,1:PSJC["N") W $S($P(ND4,"^",12):"D",1:" ")
37 S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")
38 I STAT="A",$P(ND,U,27)="R" S STAT="R"
39 S NF=$P(DN,"^",2),WS=$S(PSJPWD:$$WS(PSJPWD,PSGP,PSJF,PSJO),1:0)
40 NEW MARX,PSJRNDT
41 S PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO) S:PSJRNDT PSJRNDT=$E($$ENDTC^PSGMI(+PSJRNDT),1,5)
42 D DRGDISP^PSJLMUT1(PSGP,+PSJO_$S(PSJC["A":"U",PSJC["O":"U",1:"P"),40,54,.MARX,0)
43 F X=0:0 S X=$O(MARX(X)) Q:'X W @($S(X=1:"?9",1:"!?11")),$S($E(PSJS)="*":$P(PSJS,"^"),1:MARX(X)) D:X=1
44 . W ?50,$S(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?")
45 . W:'$D(PSJEXTP) ?53,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(PSGID),1,5)),?60,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(SD),1,5)),?67,STAT
46 . W:$D(PSJEXTP) ?53,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(PSGID),1,8)),?63,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(SD),1,8)),?73,STAT
47 . I NF!WS!SM!PF!(PSJRNDT]"") W ?71 W:NF "NF " W:WS "WS " W:SM $E("HSM",SM,3) W:$G(PSJRNDT) PSJRNDT W:PF ?79,"*"
48 I ND6]"" S Y=$$ENSET^PSGSICHK(ND6) W !?11 F X=1:1:$L(Y," ") S V=$P(Y," ",X) W:$L(V)+$X>66 !?11 W V_" "
49 Q
50 ;
51TF ;
52 NEW SLS,C S SLS="",C=PSJC,$P(SLS," -",40)=""
53 S LN2=$S(C="A":"A C T I V E",C["CC":"P E N D I N G R E N E W A L S",C["CD":"P E N D I N G C O M P L E X",C["BD":"N O N - V E R I F I E D C O M P L E X",C["C":"P E N D I N G ",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V E")
54 W:$D(^TMP("PSJ",$J,PSJC)) !,$E($E(SLS,1,(80-$L(LN2))/2)_" "_LN2_$E(SLS,1,(80-$L(LN2))/2),1,80)
55 S PSJF="^PS("_$S(PSJC'["C":"55,"_PSGP_",5,",1:"53.1,") S TF=$S(PSJC["C":0,1:TF)
56 Q
57 ;
58 ;
59BOT ; print name, ssn, and dob on bottom of page
60 F Q=$Y:1:IOSL-4 W !
61 W !,?2,$P(PSGP(0),"^"),?40,PSJPPID,?70,$E($P(PSJPDOB,"^",2),1,8)
62 Q
63WS(PSJPWD,PSGP,PSJF,PSJO) ; - WARD STOCK flag, input=(ward,dfn,file root,order)
64 ; Naked reference below refers to full reference ^PS(55,DFN,5,+PSJO,1,"B",PSWS) using indirection.
65 S WS=0,PSJF=PSJF_+PSJO_",1,""B"")" I $D(@PSJF) N PSWS S PSWS=0 F S PSWS=$O(^("B",PSWS)) Q:'PSWS S WS=$$WSCHK(PSJPWD,PSWS) Q:WS
66 Q WS
67 ;
68WSCHK(PSJPWD,PSWS) ; Determine if drug is ward stock item.
69 Q $S(PSJPWD:$S($D(^PSI(58.1,"D",PSWS,PSJPWD)):1,$D(^PSD(58.8,"D",PSWS,PSJPWD)):1,1:0),1:0)
Note: See TracBrowser for help on using the repository browser.