PSGPER2 ;BIR/CML3-PRINTS PRE-EXCHANGE NEEDS REPORT ;18 MAR 03 / 5:14 PM
;;5.0;INPATIENT MEDICATIONS;**80,115,279**;16 DEC 97;Build 150
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
ENQ ; Tasked entry point
D ENP
D TASKPRGE^PSGPER1(PSGPXN)
K DA,DIK,PSGPXN
Q
;
ENP ;
N PSGPRSUB S PSGPRSUB=$S($G(PSGPRTYP)="PSGPERPC":"PSGPERPC",1:"PSGPERP")
K ^TMP("PSGPERP",$J),^TMP("PSGPERPC",$J) U IO
F DFN=0:0 S DFN=$O(^PS(53.4,PSGPXN,1,DFN)) Q:'DFN D PID^VADPT,GWR F ON=0:0 S ON=$O(^PS(53.4,PSGPXN,1,DFN,1,ON)) Q:'ON D ONI F DD=0:0 S DD=$O(^PS(53.4,PSGPXN,1,DFN,1,ON,1,DD)) Q:'DD I $D(^(DD,0)) S ND=^(0) D DDS
D NOW^%DTC S %=$$ENDTC^PSGMI(%),(BORD,F,L)="",$P(L,"-",81)="",$P(BORD,"#",25)="",T=IO'=IO(0)!($E(IOST)'="C"),RF=$S(T:0,1:0) D:'RF HEADER S (DN,DDN,NP,WD)=""
F S WD=$O(^TMP(PSGPRSUB,$J,WD)) Q:WD="" S PI="" F S F=0,PI=$O(^TMP(PSGPRSUB,$J,WD,PI)) Q:PI="" S RB=$G(^(PI)) D
.Q:'$$NSYNC(PSGPRSUB,WD,$G(PSGCURCL))
.D PPI F S F=1,DN=$O(^TMP(PSGPRSUB,$J,WD,PI,DN)) Q:DN="" S PX=^(DN) D OP F S DDN=$O(^TMP(PSGPRSUB,$J,WD,PI,DN,DDN)) Q:DDN="" S PX=^(DDN) D PRT
.I $O(^TMP(PSGPRSUB,$J,WD,PI))]"" S F="" D NP
W:T&($Y) @IOF,@IOF D ^%ZISC
;
DONE ;
K ^TMP(PSGPRSUB,$J),BORD,DN,DD,DO,DRG,DRGS,F,L,MR,ND,ND0,ND2,ND4,NP,ON,PI,PDN,PN,PX,RB,RF,SCH,SDN,SN,SND1,SPN,STOP,STRT,T,UD,VD,VU,W,WD,X,XL,Y,DDN,I2,ND1,PSG25,PSG26,PSGEB,PSGEBN,PSGNODE,PSGOAT,PSGSTAT
K DONE,FIL,NF,PDM,PDRG,PSGACTO,PSGDA,PSGNEFDO,PSGNESDO,PSGPEN,PSGPENWS,PSGY,PSIVAC,PSIVCT,PSIVE,PSIVEXAM,PSIVUP,PSIVWAT,PSJH,PSJNOO,PSJNOON
Q
;
NP ;
I 'T K DIR S DIR(0)="E" W ! D ^DIR S:'Y WD="zzz" W:Y $C(13),# Q
;
W:$Y @IOF W !?20,"PRE-EXCHANGE UNITS REPORT - ",%
W !!,$S(($G(PSGCURCL)]""):"Clinic",1:"Ward"),?32,"Room-bed",!,"Patient",!?5,"Order",!?20,"Dispense Drug",?64,"U/D",?72,"Needs",!,L
W:F !!,$S(WD'="zz":WD,1:"NOT FOUND"),?32,RB,!,PN_" ("_SN_")" Q
;
GWR ;
D PID^VADPT
S WD=$G(^DPT(DFN,.1)),RB=$G(^(.101)),PN=$P($G(^(0)),"^") S:WD="" WD="zz" S:RB="" RB="NOT FOUND" S:PN="" PN=DFN_";DPT("
S SPN=$E(PN,1,20)_"^"_DFN,^TMP(PSGPRSUB,$J,WD,SPN)=PN_"^"_RB_"^"_VA("BID") Q
;
ONI ;
S ND=$G(^PS(55,DFN,5,ON,0)),DN=$G(^(.2)),SCH=$P($G(^(2)),"^"),MR=$P(ND,"^",3),ND=$$ENNPN^PSGMI($P(ND,"^",2)),DO=$P(DN,"^",2),DN=$P(DN,"^") I DN="" S DN="zz"
E S DN=$$ENPDN^PSGMI(DN)
I $G(^PS(55,DFN,5,+ON,8)) Q:(PSGPRSUB'="PSGPERPC") N CLINIC S CLINIC=+^(8) I CLINIC S CLINIC=$P($G(^SC(+CLINIC,0)),"^") I (CLINIC]"") S WD=CLINIC,^TMP("PSGPERPC",$J,WD,SPN)=PN_"^^"_VA("BID") D
.I $D(^TMP(PSGPRSUB,$J,"zz",SPN)),($O(^TMP(PSGPRSUB,$J,"zz",SPN,""))="") K ^TMP(PSGPRSUB,$J,"zz",SPN)
S:MR]"" MR=$$ENMRN^PSGMI(MR) S SDN=$E(DN,1,20)_"^"_ON,^TMP(PSGPRSUB,$J,WD,SPN,SDN)=DN_"^"_DO_"^"_MR_"^"_SCH_"^"_$P(ND,"^",2)
S ^TMP($J,"PSGPRKILL",PSGPXN,DFN,ON)=""
Q
;
DDS ;
Q:'$$NSYNC(PSGPRSUB,WD,$G(PSGCURCL))
I $G(^PS(55,DFN,5,+ON,8)) Q:(PSGPRSUB'="PSGPERPC")
S ND1=$G(^PS(55,DFN,5,ON,1,+ND,0)),UD=$P(ND1,"^",2),ND1=$$ENDDN^PSGMI(+ND1),SND1=$E(ND1,1,20)_"^"_+ND,ND=$P(ND,"^",2)
I ND#1 S ND=(ND\1)+1
S ^TMP(PSGPRSUB,$J,WD,SPN,SDN,SND1)=ND1_"^"_UD_"^"_ND
Q
;
PPI ;
S DFN=$P(PI,"^",2),PN=$P(RB,"^"),SN=$P(RB,"^",3),RB=$P(RB,"^",2) I 'RF,$Y+6>IOSL D NP Q:NP["^"
W !!,$S(WD'="zz":WD,1:"NOT FOUND"),?32,RB,!,PN," ("_SN_")" Q
;
OP ;
S PDN=$P(PX,"^"),DO=$P(PX,"^",2),MR=$P(PX,"^",3),SCH=$P(PX,"^",4)
W !?5,PDN," ",DO," ",MR,$S(MR]"":" ",1:""),SCH
Q
PRT ; find order info and print same
I 'RF,$Y+4>IOSL D NP Q:NP="^"
I 1 S PDN=$P(PX,"^"),UD=$P(PX,"^",2),PX=$P(PX,"^",3) W !?20,PDN,?62,$J($S('UD:1,$E(UD)=".":0_UD,1:UD),5),?72,$J(PX,5) Q
S ON=$P(DN,"^",2),ND=$G(^PS(55,DFN,5,ON,0)),ND2=$G(^(2)),ND4=$G(^(4)),Y=$P($G(^(6)),"^"),ND0=$G(^(.1)),DO=$P(ND0,"^",2)
S DRG=$$ENDDN^PSGMI($P(ND0,"^")),MR=$$ENMRN^PSGMI(MR) ; ,DRGS=$P($G(^(+$O(^PS(55,DFN,5,ON,1,0)),0)),"^")
I 'RF W !?5,DRG,?47,DO,?65,$J($S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD?1".".N:0_UD,1:UD),5),?75,$J(+PX,5) Q
;
S SCH=$P(ND2,"^"),STRT=$P(ND2,"^",2),STOP=$P(ND2,"^",4),VU=$P(ND4,"^",3),VD=$P(ND4,"^",4),VU=$P($G(^VA(200,+VU,0)),"^",2) S:VU="" VU=$P(ND4,"^",3)
F Q="STRT","STOP","VD" S @Q=$$ENDTC^PSGMI(@Q)
W:$Y @IOF W !!?6,BORD_" PRE-EXCHANGE MED "_BORD,!?6,"#",?73,"#",!?6,"# ",PN,?50,$S(($G(PSGCURCL)]""):"Clinic: ",1:"Ward: "),WD,?73,"#",!?6,"# ("_SN_")",?52,"RB: "_RB,?73,"#",!?6,"#",?73,"#"
W !?6,"# "_DRG,?46,"START: "_STRT,?73,"#",!?6,"# "_$S(DRGS]"":"("_DRGS_")",1:""),?47,"STOP: "_STOP,?73,"#",!?6,"# GIVE: "_$S(DO]"":" "_DO,1:"")_$S(MR]"":" "_MR,1:"")_$S(SCH]"":" "_SCH,1:""),?73,"#"
S XL=0 I Y="" W !?6,"#",?73,"#",!?6,"# (NO SPECIAL INSTRUCTIONS)"
E W !?6,"#",?73,"#",!?6,"# " S Y=$$ENSET^PSGSICHK(Y) F Q=1:1:$L(Y," ") S X=$P(Y," ",Q) S:$X+$L(X)>72 XL=XL+1 W:$X+$L(X)>72 ?73,"#",!?6,"# " W X_" "
W ?73,"#",!?6,"#",?73,"#",!,?6,"#",?43,"VERIFIED: "_VD,?73,"#",!?6,"#",?49,"BY: "_VU,?73,"#",!?6,"#",?38,"SEND TO FLOOR: "_PX,?73,"#"
S XL=2-XL I XL>0 F Q=1:1:XL W !?6,"#",?73,"#"
W !?6,"#",?73,"#",!?6,"#",?36,"_______________ _______________ #",!?6,"#",?36,"FILLED BY",?56,"CHECKED BY",?73,"#",!?6,BORD_BORD_$E(BORD,1,20) Q
;
NSYNC(PSGPRSUB,WD,PSGCURCL) ; Don't print ward orders and clinic orders together
Q:((PSGPRSUB="PSGPERPC")&(WD'=$G(PSGCURCL))) 0
Q:((PSGPRSUB'="PSGPERPC")&($G(PSGCURCL)]"")) 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPER2 5261 printed Sep 23, 2025@19:38:49 Page 2
PSGPER2 ;BIR/CML3-PRINTS PRE-EXCHANGE NEEDS REPORT ;18 MAR 03 / 5:14 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**80,115,279**;16 DEC 97;Build 150
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
ENQ ; Tasked entry point
+1 DO ENP
+2 DO TASKPRGE^PSGPER1(PSGPXN)
+3 KILL DA,DIK,PSGPXN
+4 QUIT
+5 ;
ENP ;
+1 NEW PSGPRSUB
SET PSGPRSUB=$SELECT($GET(PSGPRTYP)="PSGPERPC":"PSGPERPC",1:"PSGPERP")
+2 KILL ^TMP("PSGPERP",$JOB),^TMP("PSGPERPC",$JOB)
USE IO
+3 FOR DFN=0:0
SET DFN=$ORDER(^PS(53.4,PSGPXN,1,DFN))
if 'DFN
QUIT
DO PID^VADPT
DO GWR
FOR ON=0:0
SET ON=$ORDER(^PS(53.4,PSGPXN,1,DFN,1,ON))
if 'ON
QUIT
DO ONI
FOR DD=0:0
SET DD=$ORDER(^PS(53.4,PSGPXN,1,DFN,1,ON,1,DD))
if 'DD
QUIT
IF $DATA(^(DD,0))
SET ND=^(0)
DO DDS
+4 DO NOW^%DTC
SET %=$$ENDTC^PSGMI(%)
SET (BORD,F,L)=""
SET $PIECE(L,"-",81)=""
SET $PIECE(BORD,"#",25)=""
SET T=IO'=IO(0)!($EXTRACT(IOST)'="C")
SET RF=$SELECT(T:0,1:0)
if 'RF
DO HEADER
SET (DN,DDN,NP,WD)=""
+5 FOR
SET WD=$ORDER(^TMP(PSGPRSUB,$JOB,WD))
if WD=""
QUIT
SET PI=""
FOR
SET F=0
SET PI=$ORDER(^TMP(PSGPRSUB,$JOB,WD,PI))
if PI=""
QUIT
SET RB=$GET(^(PI))
Begin DoDot:1
+6 if '$$NSYNC(PSGPRSUB,WD,$GET(PSGCURCL))
QUIT
+7 DO PPI
FOR
SET F=1
SET DN=$ORDER(^TMP(PSGPRSUB,$JOB,WD,PI,DN))
if DN=""
QUIT
SET PX=^(DN)
DO OP
FOR
SET DDN=$ORDER(^TMP(PSGPRSUB,$JOB,WD,PI,DN,DDN))
if DDN=""
QUIT
SET PX=^(DDN)
DO PRT
+8 IF $ORDER(^TMP(PSGPRSUB,$JOB,WD,PI))]""
SET F=""
DO NP
End DoDot:1
+9 if T&($Y)
WRITE @IOF,@IOF
DO ^%ZISC
+10 ;
DONE ;
+1 KILL ^TMP(PSGPRSUB,$JOB),BORD,DN,DD,DO,DRG,DRGS,F,L,MR,ND,ND0,ND2,ND4,NP,ON,PI,PDN,PN,PX,RB,RF,SCH,SDN,SN,SND1,SPN,STOP,STRT,T,UD,VD,VU,W,WD,X,XL,Y,DDN,I2,ND1,PSG25,PSG26,PSGEB,PSGEBN,PSGNODE,PSGOAT,PSGSTAT
+2 KILL DONE,FIL,NF,PDM,PDRG,PSGACTO,PSGDA,PSGNEFDO,PSGNESDO,PSGPEN,PSGPENWS,PSGY,PSIVAC,PSIVCT,PSIVE,PSIVEXAM,PSIVUP,PSIVWAT,PSJH,PSJNOO,PSJNOON
+3 QUIT
+4 ;
NP ;
+1 IF 'T
KILL DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
if 'Y
SET WD="zzz"
if Y
WRITE $CHAR(13),#
QUIT
+2 ;
+1 if $Y
WRITE @IOF
WRITE !?20,"PRE-EXCHANGE UNITS REPORT - ",%
+2 WRITE !!,$SELECT(($GET(PSGCURCL)]""):"Clinic",1:"Ward"),?32,"Room-bed",!,"Patient",!?5,"Order",!?20,"Dispense Drug",?64,"U/D",?72,"Needs",!,L
+3 if F
WRITE !!,$SELECT(WD'="zz":WD,1:"NOT FOUND"),?32,RB,!,PN_" ("_SN_")"
QUIT
+4 ;
GWR ;
+1 DO PID^VADPT
+2 SET WD=$GET(^DPT(DFN,.1))
SET RB=$GET(^(.101))
SET PN=$PIECE($GET(^(0)),"^")
if WD=""
SET WD="zz"
if RB=""
SET RB="NOT FOUND"
if PN=""
SET PN=DFN_";DPT("
+3 SET SPN=$EXTRACT(PN,1,20)_"^"_DFN
SET ^TMP(PSGPRSUB,$JOB,WD,SPN)=PN_"^"_RB_"^"_VA("BID")
QUIT
+4 ;
ONI ;
+1 SET ND=$GET(^PS(55,DFN,5,ON,0))
SET DN=$GET(^(.2))
SET SCH=$PIECE($GET(^(2)),"^")
SET MR=$PIECE(ND,"^",3)
SET ND=$$ENNPN^PSGMI($PIECE(ND,"^",2))
SET DO=$PIECE(DN,"^",2)
SET DN=$PIECE(DN,"^")
IF DN=""
SET DN="zz"
+2 IF '$TEST
SET DN=$$ENPDN^PSGMI(DN)
+3 IF $GET(^PS(55,DFN,5,+ON,8))
if (PSGPRSUB'="PSGPERPC")
QUIT
NEW CLINIC
SET CLINIC=+^(8)
IF CLINIC
SET CLINIC=$PIECE($GET(^SC(+CLINIC,0)),"^")
IF (CLINIC]"")
SET WD=CLINIC
SET ^TMP("PSGPERPC",$JOB,WD,SPN)=PN_"^^"_VA("BID")
Begin DoDot:1
+4 IF $DATA(^TMP(PSGPRSUB,$JOB,"zz",SPN))
IF ($ORDER(^TMP(PSGPRSUB,$JOB,"zz",SPN,""))="")
KILL ^TMP(PSGPRSUB,$JOB,"zz",SPN)
End DoDot:1
+5 if MR]""
SET MR=$$ENMRN^PSGMI(MR)
SET SDN=$EXTRACT(DN,1,20)_"^"_ON
SET ^TMP(PSGPRSUB,$JOB,WD,SPN,SDN)=DN_"^"_DO_"^"_MR_"^"_SCH_"^"_$PIECE(ND,"^",2)
+6 SET ^TMP($JOB,"PSGPRKILL",PSGPXN,DFN,ON)=""
+7 QUIT
+8 ;
DDS ;
+1 if '$$NSYNC(PSGPRSUB,WD,$GET(PSGCURCL))
QUIT
+2 IF $GET(^PS(55,DFN,5,+ON,8))
if (PSGPRSUB'="PSGPERPC")
QUIT
+3 SET ND1=$GET(^PS(55,DFN,5,ON,1,+ND,0))
SET UD=$PIECE(ND1,"^",2)
SET ND1=$$ENDDN^PSGMI(+ND1)
SET SND1=$EXTRACT(ND1,1,20)_"^"_+ND
SET ND=$PIECE(ND,"^",2)
+4 IF ND#1
SET ND=(ND\1)+1
+5 SET ^TMP(PSGPRSUB,$JOB,WD,SPN,SDN,SND1)=ND1_"^"_UD_"^"_ND
+6 QUIT
+7 ;
PPI ;
+1 SET DFN=$PIECE(PI,"^",2)
SET PN=$PIECE(RB,"^")
SET SN=$PIECE(RB,"^",3)
SET RB=$PIECE(RB,"^",2)
IF 'RF
IF $Y+6>IOSL
DO NP
if NP["^"
QUIT
+2 WRITE !!,$SELECT(WD'="zz":WD,1:"NOT FOUND"),?32,RB,!,PN," ("_SN_")"
QUIT
+3 ;
OP ;
+1 SET PDN=$PIECE(PX,"^")
SET DO=$PIECE(PX,"^",2)
SET MR=$PIECE(PX,"^",3)
SET SCH=$PIECE(PX,"^",4)
+2 WRITE !?5,PDN," ",DO," ",MR,$SELECT(MR]"":" ",1:""),SCH
+3 QUIT
PRT ; find order info and print same
+1 IF 'RF
IF $Y+4>IOSL
DO NP
if NP="^"
QUIT
+2 IF 1
SET PDN=$PIECE(PX,"^")
SET UD=$PIECE(PX,"^",2)
SET PX=$PIECE(PX,"^",3)
WRITE !?20,PDN,?62,$JUSTIFY($SELECT('UD:1,$EXTRACT(UD)=".":0_UD,1:UD),5),?72,$JUSTIFY(PX,5)
QUIT
+3 SET ON=$PIECE(DN,"^",2)
SET ND=$GET(^PS(55,DFN,5,ON,0))
SET ND2=$GET(^(2))
SET ND4=$GET(^(4))
SET Y=$PIECE($GET(^(6)),"^")
SET ND0=$GET(^(.1))
SET DO=$PIECE(ND0,"^",2)
+4 ; ,DRGS=$P($G(^(+$O(^PS(55,DFN,5,ON,1,0)),0)),"^")
SET DRG=$$ENDDN^PSGMI($PIECE(ND0,"^"))
SET MR=$$ENMRN^PSGMI(MR)
+5 IF 'RF
WRITE !?5,DRG,?47,DO,?65,$JUSTIFY($SELECT('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD?1".".N:0_UD,1:UD),5),?75,$JUSTIFY(+PX,5)
QUIT
+6 ;
+7 SET SCH=$PIECE(ND2,"^")
SET STRT=$PIECE(ND2,"^",2)
SET STOP=$PIECE(ND2,"^",4)
SET VU=$PIECE(ND4,"^",3)
SET VD=$PIECE(ND4,"^",4)
SET VU=$PIECE($GET(^VA(200,+VU,0)),"^",2)
if VU=""
SET VU=$PIECE(ND4,"^",3)
+8 FOR Q="STRT","STOP","VD"
SET @Q=$$ENDTC^PSGMI(@Q)
+9 if $Y
WRITE @IOF
WRITE !!?6,BORD_" PRE-EXCHANGE MED "_BORD,!?6,"#",?73,"#",!?6,"# ",PN,?50,$SELECT(($GET(PSGCURCL)]""):"Clinic: ",1:"Ward: "),WD,?73,"#",!?6,"# ("_SN_")",?52,"RB: "_RB,?73,"#",!?6,"#",?73,"#"
+10 WRITE !?6,"# "_DRG,?46,"START: "_STRT,?73,"#",!?6,"# "_$SELECT(DRGS]"":"("_DRGS_")",1:""),?47,"STOP: "_STOP,?73,"#",!?6,"# GIVE: "_$SELECT(DO]"":" "_DO,1:"")_$SELECT(MR]"":" "_MR,1:"")_$SELECT(SCH]"":" "_SCH,1:""),?73,"#"
+11 SET XL=0
IF Y=""
WRITE !?6,"#",?73,"#",!?6,"# (NO SPECIAL INSTRUCTIONS)"
+12 IF '$TEST
WRITE !?6,"#",?73,"#",!?6,"# "
SET Y=$$ENSET^PSGSICHK(Y)
FOR Q=1:1:$LENGTH(Y," ")
SET X=$PIECE(Y," ",Q)
if $X+$LENGTH(X)>72
SET XL=XL+1
if $X+$LENGTH(X)>72
WRITE ?73,"#",!?6,"# "
WRITE X_" "
+13 WRITE ?73,"#",!?6,"#",?73,"#",!,?6,"#",?43,"VERIFIED: "_VD,?73,"#",!?6,"#",?49,"BY: "_VU,?73,"#",!?6,"#",?38,"SEND TO FLOOR: "_PX,?73,"#"
+14 SET XL=2-XL
IF XL>0
FOR Q=1:1:XL
WRITE !?6,"#",?73,"#"
+15 WRITE !?6,"#",?73,"#",!?6,"#",?36,"_______________ _______________ #",!?6,"#",?36,"FILLED BY",?56,"CHECKED BY",?73,"#",!?6,BORD_BORD_$EXTRACT(BORD,1,20)
QUIT
+16 ;
NSYNC(PSGPRSUB,WD,PSGCURCL) ; Don't print ward orders and clinic orders together
+1 if ((PSGPRSUB="PSGPERPC")&(WD'=$GET(PSGCURCL)))
QUIT 0
+2 if ((PSGPRSUB'="PSGPERPC")&($GET(PSGCURCL)]""))
QUIT 0
+3 QUIT 1
