- PSJO ;BIR/CML3,PR - GET AND PRINT INPATIENT ORDERS ;Jul 16, 2018@08:25
- ;;5.0;INPATIENT MEDICATIONS;**31,58,110,181,267,275,317,373**;16 DEC 97;Build 3
- ;
- ; Reference to ^PSD(58.8 supported by DBIA #2283.
- ; Reference to ^PSI(58.1 supported by DBIA #2284.
- ; Reference to ^PS(55 supported by DBIA #2191.
- ; Reference to $$GET^XPAR supported by #2263
- ;
- K ^TMP("PSJON",$J),^TMP("PSJ",$J) N TF2 D @$S($D(PSJEXTP):"EN^PSJH1",1:"EN^PSJO1(3)")
- S PSJDEV=IO'=IO(0)!($E(IOST,1,2)'="C-"),(NP,TF2,PSGON,PSJON)=""
- 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."
- E S (PSJC,PSJS,PSJO,PSJST)="" F S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC="" D G:NP["^" DONE
- .D:$S(($P(PSJC,"^")="Cz")&($P(PSJC,"^",2)'=TF2):1,(($P(PSJC,"^")'="Cz")&PSJC["B"&'TF):0,($P(PSJC,"^")'="Cz"&(PSJC'["A")):1,($P(PSJC,"^")="Cz"&(TF2=$P(PSJC,"^",2))):0,1:1) TF
- .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
- G:NP[U DONE I PSJDEV,$S('$D(PSJPRP):1,1:PSJPRP="P") D BOT
- ;
- DONE ;
- I $S('$D(PSJPRP):1,1:PSJPRP="P") K ^TMP("PSJ",$J)
- 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
- K ST,START,STAT,SUB,TF,TYP,UDU,UPD,V,WS,X,X1,X2,Y Q
- ;
- ON ;
- S PSJSCHT=$S(PSJOS:PSJS,1:PSJST)
- 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 ;
- .I $P(PSJC,"^")="Cz",($P(PSJC,"^",2)]"") S PSJF="^PS("_$S($P(PSJC,"^",4)'["C":"55,"_PSGP_",5,",1:"53.1,")
- .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)")
- Q
- ;
- PUD ; print unit dose
- ; Naked reference below refers to full reference ^PS(53.1,+PSJO,0) or ^PS(55,DFN,5,+PSJO,0) using indirection.
- I PSJO["U" S:'$$CLINIC^PSJO1(PSGP,PSJO) C=$G(PSJC)
- I PSJO["P" S:'$$CLINIC^PSJO1(PSGP,PSJO) C=$G(PSJC)
- 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)")))
- I ("AO"[PSJC)!(PSJC="DF") D
- .S V='$P(ND4,"^",UDU),V=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
- .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 $S($P($G(@(PSJF_+PSJO_",.2)")),"^",4)="D":"d",1:" ")_$S(V:"->",1:" ")
- I $S(PSJC["NZ":0,1:PSJC["N") W $S($P(ND4,"^",12):"D",1:" ")
- S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",28)]"":$P(ND,"^",28),$P(ND,"^",9)]"":$P(ND,"^",9),1:"NF")
- S PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")
- I STAT="A",$P(ND,U,27)="R" S STAT="R"
- S NF=$P(DN,"^",2),WS=$S(PSJPWD:$$WS(PSJPWD,PSGP,PSJF,PSJO),1:0)
- ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display.
- N PADE S PADE=0 I $$GET^XPAR("SYS","PSJ PADE OE BALANCES") D
- .N PSJTMNOE
- .S PSJTMNOE=$G(PSJNEWOE) N PSJNEWOE S PSJNEWOE=PSJTMNOE
- .I '$G(VAIN(4)),$G(PSGP) N VAIN,DFN S DFN=PSGP D INP^VADPT
- .Q:'$$PADEWD^PSJPAD50(+$G(VAIN(4)))
- .S PADE=$$DRGFLAG^PSJPADSI(PSGP,PSJO,,$G(ON),$G(PSJNEWOE)) S:PADE=0 PADE=1
- NEW MARX,PSJRNDT
- S:($P(PSJC,"^")'="Cz") PSJORFLG=$S(PSJC["A":"U",PSJC["O":"U",PSJC="DF":"U",1:"P")
- S:($P(PSJC,"^")="Cz") PSJORFLG=$S($P(PSJC,"^",4)["A":"U",($P(PSJC,"^",4)["O"):"U",($P(PSJC,"^",4)["DF"):"U",1:"P")
- ;S PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO) S:PSJRNDT PSJRNDT=$E($$ENDTC^PSGMI(+PSJRNDT),1,5) ;#373
- S PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO) S:PSJRNDT PSJRNDT=$E($$ENDTC2^PSGMI(+PSJRNDT),1,10) ;#373
- ;D DRGDISP^PSJLMUT1(PSGP,+PSJO_PSJORFLG,40,54,.MARX,0) ;#373
- D DRGDISP^PSJLMUT1(PSGP,+PSJO_PSJORFLG,34,28,.MARX,0) ;#373
- 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 ;D:X=1 #373
- . ;W ?50,$S(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?") ;#373
- . I X=1 W ?46,$S(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?") ;#373
- . ;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 ;#373
- . I X=1 W:'$D(PSJEXTP) ?49,$S(PSJC["NZ":"*****",1:$E($$ENDTC2^PSGMI(PSGID),1,10)),?60,$S(PSJC["NZ":"*****",1:$E($$ENDTC2^PSGMI(SD),1,10)),?71,STAT ;#373
- . ;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 ;#373
- . I X=1 W:$D(PSJEXTP) ?49,$S(PSJC["NZ":"*****",1:$E($$ENDTC2^PSGMI(PSGID),1,10)),?60,$S(PSJC["NZ":"*****",1:$E($$ENDTC2^PSGMI(SD),1,10)),?71,STAT ;#373
- . ;I NF!WS!SM!PF!$G(PADE)!(PSJRNDT]"") W ?71 W:NF "NF " W:(WS&'PADE) "WS " W:(WS&PADE) "WP " W:(PADE&'WS) "PD " W:SM $E("HSM",SM,3) W:$G(PSJRNDT) PSJRNDT W:PF ?79,"*" ;#373
- . I X=1 D ;#373
- .. I NF!WS!SM!PF!$G(PADE) W ?74 W:NF "NF " W:(WS&'PADE) "WS " W:(WS&PADE) "WP " W:(PADE&'WS) "PD " W:SM $E("HSM",SM,3) W:PF ?78,"*" ;#373
- . I X=2,PSJRNDT]"" W ?49,"Renewed: ",PSJRNDT ;#373
- I '$D(MARX(2)),PSJRNDT]"" W !?49,"Renewed: ",PSJRNDT ;#373
- I ND6]"" S Y=$$ENSET^PSGSICHK(ND6) D K ^PS(53.45,DUZ,5)
- .D GETSI^PSJBCMA5(DFN,PSJO) I $G(^PS(53.45,DUZ,5)) N TXTLN S TXTLN=0 F S TXTLN=$O(^PS(53.45,DUZ,5,TXTLN)) Q:'TXTLN D
- ..W !?11,$G(^PS(53.45,DUZ,5,TXTLN,0))
- .W !?11 F X=1:1:$L(Y," ") S V=$P(Y," ",X) W:$L(V)+$X>66 !?11 W V_" "
- K PSJORFLG
- Q
- ;
- TF ;
- NEW SLS,C S SLS="",C=PSJC,$P(SLS," -",40)=""
- S LN2=$S(($P(C,"^")="Cz"):$$TXT(C),C="A":$$TXT(C),C["CC":$$TXT("PR"),C["CD":$$TXT("PC"),C["BD":$$TXT("NC"),C["C":$$TXT("P"),C["B":$$TXT("N"),C["NX":$$TXT("N"),C["DF":$$TXT("DF"),C["NZ":$$TXT("P"),1:$$TXT("NA"))
- W:$D(^TMP("PSJ",$J,PSJC)) !,$E($E(SLS,1,(80-$L(LN2))/2)_" "_LN2_$E(SLS,1,(80-$L(LN2))/2),1,80)
- S PSJF="^PS("_$S(PSJC'["C":"55,"_PSGP_",5,",1:"53.1,") S TF=$S(PSJC["C":0,1:TF)
- I $P(PSJC,"^")="Cz",($P(PSJC,"^",2)]"") S PSJF="^PS("_$S($P(PSJC,"^",4)'["C":"55,"_PSGP_",5,",1:"53.1,"),TF2=$P(PSJC,"^",2)
- Q
- ;
- TXT(X) ;
- I $G(X)="" Q ""
- I X="A" Q "A C T I V E"
- S PSJDCEXP=$$RECDCEXP^PSJP()
- I $P(X,"^")="Cz" Q $P(X,"^",2)
- I X="DF" Q "RECENTLY DISCONTINUED/EXPIRED (LAST "_+$G(PSJDCEXP)_" HOURS)"
- I X="N" Q "N O N - V E R I F I E D"
- I X="NA" Q "N O N - A C T I V E"
- I X="NC" Q "N O N - V E R I F I E D C O M P L E X"
- I X="P" Q "P E N D I N G"
- I X="PC" Q "P E N D I N G C O M P L E X"
- I X="PR" Q "P E N D I N G R E N E W A L S"
- Q ""
- ;
- BOT ; print name, ssn, and dob on bottom of page
- F Q=$Y:1:IOSL-4 W !
- W !,?2,$P(PSGP(0),"^"),?40,PSJPPID,?70,$E($P(PSJPDOB,"^",2),1,8)
- Q
- WS(PSJPWD,PSGP,PSJF,PSJO) ; - WARD STOCK flag, input=(ward,dfn,file root,order)
- ; Naked reference below refers to full reference ^PS(55,DFN,5,+PSJO,1,"B",PSWS) using indirection.
- 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
- Q WS
- ;
- WSCHK(PSJPWD,PSWS) ; Determine if drug is ward stock item.
- Q $S(PSJPWD:$S($D(^PSI(58.1,"D",PSWS,PSJPWD)):1,$D(^PSD(58.8,"D",PSWS,PSJPWD)):1,1:0),1:0)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJO 7229 printed Jan 18, 2025@03:09:08 Page 2
- PSJO ;BIR/CML3,PR - GET AND PRINT INPATIENT ORDERS ;Jul 16, 2018@08:25
- +1 ;;5.0;INPATIENT MEDICATIONS;**31,58,110,181,267,275,317,373**;16 DEC 97;Build 3
- +2 ;
- +3 ; Reference to ^PSD(58.8 supported by DBIA #2283.
- +4 ; Reference to ^PSI(58.1 supported by DBIA #2284.
- +5 ; Reference to ^PS(55 supported by DBIA #2191.
- +6 ; Reference to $$GET^XPAR supported by #2263
- +7 ;
- +8 KILL ^TMP("PSJON",$JOB),^TMP("PSJ",$JOB)
- NEW TF2
- DO @$SELECT($DATA(PSJEXTP):"EN^PSJH1",1:"EN^PSJO1(3)")
- +9 SET PSJDEV=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")
- SET (NP,TF2,PSGON,PSJON)=""
- +10 USE IO
- DO ENGET^PSJO3
- IF '$DATA(^TMP("PSJ",$JOB))
- WRITE !,SLS,SLS,$EXTRACT(SLS,1,25),!!?22,"NO ORDERS FOUND FOR ",$SELECT(PSJOL="S":"SHORT",1:"LONG")," PROFILE."
- +11 IF '$TEST
- SET (PSJC,PSJS,PSJO,PSJST)=""
- FOR
- SET PSJC=$ORDER(^TMP("PSJ",$JOB,PSJC))
- if PSJC=""
- QUIT
- Begin DoDot:1
- +12 if $SELECT(($PIECE(PSJC,"^")="Cz")&($PIECE(PSJC,"^",2)'=TF2)
- DO TF
- +13 FOR
- SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))
- if PSJST=""
- QUIT
- FOR
- SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))
- if PSJS=""!(NP[U)
- QUIT
- DO ON
- End DoDot:1
- if NP["^"
- GOTO DONE
- +14 if NP[U
- GOTO DONE
- IF PSJDEV
- IF $SELECT('$DATA(PSJPRP):1,1:PSJPRP="P")
- DO BOT
- +15 ;
- DONE ;
- +1 IF $SELECT('$DATA(PSJPRP):1,1:PSJPRP="P")
- KILL ^TMP("PSJ",$JOB)
- +2 SET PSGON=PSJON
- if '$DATA(PSGVBW)
- KILL PSGODT
- KILL %,%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
- +3 KILL ST,START,STAT,SUB,TF,TYP,UDU,UPD,V,WS,X,X1,X2,Y
- QUIT
- +4 ;
- ON ;
- +1 SET PSJSCHT=$SELECT(PSJOS:PSJS,1:PSJST)
- +2 ;
- FOR FQ=0:0
- SET PSJO=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS,PSJO))
- if PSJO=""
- QUIT
- SET DN=^(PSJO)
- if $Y+6>IOSL
- DO ENNP^PSJO3
- if NP["^"
- QUIT
- Begin DoDot:1
- +3 IF $PIECE(PSJC,"^")="Cz"
- IF ($PIECE(PSJC,"^",2)]"")
- SET PSJF="^PS("_$SELECT($PIECE(PSJC,"^",4)'["C":"55,"_PSGP_",5,",1:"53.1,")
- +4 SET PSJON=PSJON+1
- if 'PSJDEV
- SET ^TMP("PSJON",$JOB,PSJON)=PSJO
- WRITE !,$JUSTIFY(PSJON,4),?5
- DO @$SELECT(PSJO["V":"PIV^PSIVUTL(PSJO)",PSJO["U":"PUD",1:"PIV^PSIVUTL(PSJO)")
- End DoDot:1
- +5 QUIT
- +6 ;
- PUD ; print unit dose
- +1 ; Naked reference below refers to full reference ^PS(53.1,+PSJO,0) or ^PS(55,DFN,5,+PSJO,0) using indirection.
- +2 IF PSJO["U"
- if '$$CLINIC^PSJO1(PSGP,PSJO)
- SET C=$GET(PSJC)
- +3 IF PSJO["P"
- if '$$CLINIC^PSJO1(PSGP,PSJO)
- SET C=$GET(PSJC)
- +4 SET ND=$SELECT($DATA(@(PSJF_+PSJO_",0)")):^(0),1:"")
- SET SCH=$GET(^(2))
- SET ND4=$GET(^(4))
- SET ND6=$PIECE($GET(^(6)),"^")
- SET DO=$SELECT($PIECE(DN,"^",2)=.2:$PIECE($GET(@(PSJF_+PSJO_",.2)")),"^",2),1:$GET(@(PSJF_+PSJO_",.3)")))
- +5 IF ("AO"[PSJC)!(PSJC="DF")
- Begin DoDot:1
- +6 SET V='$PIECE(ND4,"^",UDU)
- SET V=$SELECT(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
- +7 WRITE $SELECT(ND4="":" ",$PIECE(ND4,"^",12):"D",$PIECE(ND4,"^",18)&($PIECE(ND4,"^",19)!V):"H",$PIECE(ND4,"^",22)&($PIECE(ND4,"^",23)!V):"H",$PIECE(ND4,"^",15)&($PIECE(ND4,"^",16)!V):"R",1:" ")
- +8 WRITE $SELECT($PIECE($GET(@(PSJF_+PSJO_",.2)")),"^",4)="D":"d",1:" ")_$SELECT(V:"->",1:" ")
- End DoDot:1
- +9 IF $SELECT(PSJC["NZ":0,1:PSJC["N")
- WRITE $SELECT($PIECE(ND4,"^",12):"D",1:" ")
- +10 SET RTE=$PIECE(ND,"^",3)
- SET SM=$SELECT('$PIECE(ND,"^",5):0,$PIECE(ND,"^",6):1,1:2)
- SET STAT=$SELECT($PIECE(ND,"^",28)]"":$PIECE(ND,"^",28),$PIECE(ND,"^",9)]"":$PIECE(ND,"^",9),1:"NF")
- +11 SET PF=$EXTRACT("*",$PIECE(ND,"^",20)>0)
- SET PSGID=$PIECE(SCH,"^",2)
- SET SD=$PIECE(SCH,"^",4)
- SET SCH=$PIECE(SCH,"^")
- +12 IF STAT="A"
- IF $PIECE(ND,U,27)="R"
- SET STAT="R"
- +13 SET NF=$PIECE(DN,"^",2)
- SET WS=$SELECT(PSJPWD:$$WS(PSJPWD,PSGP,PSJF,PSJO),1:0)
- +14 ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display.
- +15 NEW PADE
- SET PADE=0
- IF $$GET^XPAR("SYS","PSJ PADE OE BALANCES")
- Begin DoDot:1
- +16 NEW PSJTMNOE
- +17 SET PSJTMNOE=$GET(PSJNEWOE)
- NEW PSJNEWOE
- SET PSJNEWOE=PSJTMNOE
- +18 IF '$GET(VAIN(4))
- IF $GET(PSGP)
- NEW VAIN,DFN
- SET DFN=PSGP
- DO INP^VADPT
- +19 if '$$PADEWD^PSJPAD50(+$GET(VAIN(4)))
- QUIT
- +20 SET PADE=$$DRGFLAG^PSJPADSI(PSGP,PSJO,,$GET(ON),$GET(PSJNEWOE))
- if PADE=0
- SET PADE=1
- End DoDot:1
- +21 NEW MARX,PSJRNDT
- +22 if ($PIECE(PSJC,"^")'="Cz")
- SET PSJORFLG=$SELECT(PSJC["A":"U",PSJC["O":"U",PSJC="DF":"U",1:"P")
- +23 if ($PIECE(PSJC,"^")="Cz")
- SET PSJORFLG=$SELECT($PIECE(PSJC,"^",4)["A":"U",($PIECE(PSJC,"^",4)["O"):"U",($PIECE(PSJC,"^",4)["DF"):"U",1:"P")
- +24 ;S PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO) S:PSJRNDT PSJRNDT=$E($$ENDTC^PSGMI(+PSJRNDT),1,5) ;#373
- +25 ;#373
- SET PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO)
- if PSJRNDT
- SET PSJRNDT=$EXTRACT($$ENDTC2^PSGMI(+PSJRNDT),1,10)
- +26 ;D DRGDISP^PSJLMUT1(PSGP,+PSJO_PSJORFLG,40,54,.MARX,0) ;#373
- +27 ;#373
- DO DRGDISP^PSJLMUT1(PSGP,+PSJO_PSJORFLG,34,28,.MARX,0)
- +28 ;D:X=1 #373
- FOR X=0:0
- SET X=$ORDER(MARX(X))
- if 'X
- QUIT
- WRITE @($SELECT(X=1:"?9",1:"!?11")),$SELECT($EXTRACT(PSJS)="*":$PIECE(PSJS,"^"),1:MARX(X))
- Begin DoDot:1
- +29 ;W ?50,$S(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?") ;#373
- +30 ;#373
- IF X=1
- WRITE ?46,$SELECT(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?")
- +31 ;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 ;#373
- +32 ;#373
- IF X=1
- if '$DATA(PSJEXTP)
- WRITE ?49,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC2^PSGMI(PSGID),1,10)),?60,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC2^PSGMI(SD),1,10)),?71,STAT
- +33 ;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 ;#373
- +34 ;#373
- IF X=1
- if $DATA(PSJEXTP)
- WRITE ?49,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC2^PSGMI(PSGID),1,10)),?60,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC2^PSGMI(SD),1,10)),?71,STAT
- +35 ;I NF!WS!SM!PF!$G(PADE)!(PSJRNDT]"") W ?71 W:NF "NF " W:(WS&'PADE) "WS " W:(WS&PADE) "WP " W:(PADE&'WS) "PD " W:SM $E("HSM",SM,3) W:$G(PSJRNDT) PSJRNDT W:PF ?79,"*" ;#373
- +36 ;#373
- IF X=1
- Begin DoDot:2
- +37 ;#373
- IF NF!WS!SM!PF!$GET(PADE)
- WRITE ?74
- if NF
- WRITE "NF "
- if (WS&'PADE)
- WRITE "WS "
- if (WS&PADE)
- WRITE "WP "
- if (PADE&'WS)
- WRITE "PD "
- if SM
- WRITE $EXTRACT("HSM",SM,3)
- if PF
- WRITE ?78,"*"
- End DoDot:2
- +38 ;#373
- IF X=2
- IF PSJRNDT]""
- WRITE ?49,"Renewed: ",PSJRNDT
- End DoDot:1
- +39 ;#373
- IF '$DATA(MARX(2))
- IF PSJRNDT]""
- WRITE !?49,"Renewed: ",PSJRNDT
- +40 IF ND6]""
- SET Y=$$ENSET^PSGSICHK(ND6)
- Begin DoDot:1
- +41 DO GETSI^PSJBCMA5(DFN,PSJO)
- IF $GET(^PS(53.45,DUZ,5))
- NEW TXTLN
- SET TXTLN=0
- FOR
- SET TXTLN=$ORDER(^PS(53.45,DUZ,5,TXTLN))
- if 'TXTLN
- QUIT
- Begin DoDot:2
- +42 WRITE !?11,$GET(^PS(53.45,DUZ,5,TXTLN,0))
- End DoDot:2
- +43 WRITE !?11
- FOR X=1:1:$LENGTH(Y," ")
- SET V=$PIECE(Y," ",X)
- if $LENGTH(V)+$X>66
- WRITE !?11
- WRITE V_" "
- End DoDot:1
- KILL ^PS(53.45,DUZ,5)
- +44 KILL PSJORFLG
- +45 QUIT
- +46 ;
- TF ;
- +1 NEW SLS,C
- SET SLS=""
- SET C=PSJC
- SET $PIECE(SLS," -",40)=""
- +2 SET LN2=$SELECT(($PIECE(C,"^")="Cz"):$$TXT(C),C="A":$$TXT(C),C["CC":$$TXT("PR"),C["CD":$$TXT("PC"),C["BD":$$TXT("NC"),C["C":$$TXT("P"),C["B":$$TXT("N"),C["NX":$$TXT("N"),C["DF":$$TXT("DF"),C["NZ":$$TXT("P"),1:$$TXT("NA"))
- +3 if $DATA(^TMP("PSJ",$JOB,PSJC))
- WRITE !,$EXTRACT($EXTRACT(SLS,1,(80-$LENGTH(LN2))/2)_" "_LN2_$EXTRACT(SLS,1,(80-$LENGTH(LN2))/2),1,80)
- +4 SET PSJF="^PS("_$SELECT(PSJC'["C":"55,"_PSGP_",5,",1:"53.1,")
- SET TF=$SELECT(PSJC["C":0,1:TF)
- +5 IF $PIECE(PSJC,"^")="Cz"
- IF ($PIECE(PSJC,"^",2)]"")
- SET PSJF="^PS("_$SELECT($PIECE(PSJC,"^",4)'["C":"55,"_PSGP_",5,",1:"53.1,")
- SET TF2=$PIECE(PSJC,"^",2)
- +6 QUIT
- +7 ;
- TXT(X) ;
- +1 IF $GET(X)=""
- QUIT ""
- +2 IF X="A"
- QUIT "A C T I V E"
- +3 SET PSJDCEXP=$$RECDCEXP^PSJP()
- +4 IF $PIECE(X,"^")="Cz"
- QUIT $PIECE(X,"^",2)
- +5 IF X="DF"
- QUIT "RECENTLY DISCONTINUED/EXPIRED (LAST "_+$GET(PSJDCEXP)_" HOURS)"
- +6 IF X="N"
- QUIT "N O N - V E R I F I E D"
- +7 IF X="NA"
- QUIT "N O N - A C T I V E"
- +8 IF X="NC"
- QUIT "N O N - V E R I F I E D C O M P L E X"
- +9 IF X="P"
- QUIT "P E N D I N G"
- +10 IF X="PC"
- QUIT "P E N D I N G C O M P L E X"
- +11 IF X="PR"
- QUIT "P E N D I N G R E N E W A L S"
- +12 QUIT ""
- +13 ;
- BOT ; print name, ssn, and dob on bottom of page
- +1 FOR Q=$Y:1:IOSL-4
- WRITE !
- +2 WRITE !,?2,$PIECE(PSGP(0),"^"),?40,PSJPPID,?70,$EXTRACT($PIECE(PSJPDOB,"^",2),1,8)
- +3 QUIT
- WS(PSJPWD,PSGP,PSJF,PSJO) ; - WARD STOCK flag, input=(ward,dfn,file root,order)
- +1 ; Naked reference below refers to full reference ^PS(55,DFN,5,+PSJO,1,"B",PSWS) using indirection.
- +2 SET WS=0
- SET PSJF=PSJF_+PSJO_",1,""B"")"
- IF $DATA(@PSJF)
- NEW PSWS
- SET PSWS=0
- FOR
- SET PSWS=$ORDER(^("B",PSWS))
- if 'PSWS
- QUIT
- SET WS=$$WSCHK(PSJPWD,PSWS)
- if WS
- QUIT
- +3 QUIT WS
- +4 ;
- WSCHK(PSJPWD,PSWS) ; Determine if drug is ward stock item.
- +1 QUIT $SELECT(PSJPWD:$SELECT($DATA(^PSI(58.1,"D",PSWS,PSJPWD)):1,$DATA(^PSD(58.8,"D",PSWS,PSJPWD)):1,1:0),1:0)