PSOEXBCH ;BIR/RTR-print external interface list to a printer ;1/1/96
;;7.0;OUTPATIENT PHARMACY;**26**;DEC 1997
;External reference to ^PSDRUG supported by DBIA 221
QUE K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP W !,"NOTHING PRINTED" Q
I $E(IOST)'["P" W !!,"This report must be sent to a printer!",! G QUE
I $D(IO("Q")) S ZTRTN="LIST^PSOEXBCH",ZTDESC="Report of printed interface batches",ZTSAVE("^TMP($J,""PSOHLRES"",")="",ZTSAVE("^TMP($J,""PSOHLSPR"",")="",ZTSAVE("PSOSITE")="" D ^%ZTLOAD,MSQ D ^%ZISC Q
D MSNQ
LIST U IO K PSOIOF S SBFLAG=0 F LLL=0:0 S LLL=$O(^TMP($J,"PSOHLSPR",LLL)) Q:'LLL D GETN D
.D HEAD S REDT=$O(^TMP($J,"PSOHLRES",LLL,0)),REDUZ=$O(^TMP($J,"PSOHLRES",LLL,REDT,PSOSITE,0)) F SS=0:0 S SS=$O(^PS(52.51,"AS",REDT,PSOSITE,REDUZ,SS)) Q:'SS D
..I $D(^PS(52.51,SS,0)),$P($G(^(0)),"^",11)=PSOSITE S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) D
...;D STAT^PSOEXRST
...S HLZZNAME=$P($G(^DPT(+$P($G(^PSRX(INRX,0)),"^",2),0)),"^")
...S HLZZDRUG=$P($G(^PSDRUG(+$P($G(^PSRX(INRX,0)),"^",6),0)),"^"),HLZZDRUL=$L($G(HLZZDRUG))
...W !,$P(^PSRX(INRX,0),"^"),?13,$G(HLZZNAME) S SBFLAG=1
...I +$G(HLZZDRUL)<37 W ?44,$G(HLZZDRUG)
...I +$G(HLZZDRUL)>36 W !?38,$G(HLZZDRUG)
...I $Y+5>IOSL,$O(^PS(52.51,"AS",REDT,PSOSITE,REDUZ,SS)) S PSOIOF=1 D HEAD K PSOIOF
I '$G(SBFLAG) W !!,"No Rx's to print!",!
W !!,"END OF LIST"
G END
HEAD S PSOPTIME=$O(^TMP($J,"PSOHLRES",LLL,0)),PSOPDUZ=$O(^TMP($J,"PSOHLRES",LLL,PSOPTIME,PSOSITE,0)) S Y=PSOPTIME X ^DD("DD") S PSOPTIME=Y
I '$G(SBFLAG) W @IOF
I $G(PSOIOF) W @IOF
I '$G(PSOIOF),$G(SBFLAG),$Y+5>IOSL W @IOF
I $G(SBFLAG) W !
W !!,"ORIGINALLY QUEUED FOR ",$G(PSOPTIME)," BY ",$S($D(^VA(200,+$G(PSOPDUZ),0)):$E($P(^(0),"^"),1,31),1:"UNKNOWN"),!,"RX #",?13,"PATIENT NAME",?44,"BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
Q
END W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J,"PSOHLRES"),^TMP($J,"PSOHLSPR"),REDT,REDUZ,SS,GG,INRX,LLL,ZZZZ,PSOPTIME,PSOPDUZ,PSEXSTAT,PSX,HLZZDRUG,HLZZNAME,HLZZDRUL,PSOIOF Q
DEQUE K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP Q
I $E(IOST)'["P" W !!,"This report must be sent to a printer!",! G DEQUE
I $D(IO("Q")) S ZTRTN="DELIST^PSOSUBCH",ZTDESC="Report of printed suspense batch",ZTSAVE("^TMP($J,""PSODES"",")="",ZTSAVE("^TMP($J,""PSODESPR"",")="",ZTSAVE("PSOSITE")="" D ^%ZTLOAD,MSQ D ^%ZISC Q
D MSNQ
DELIST U IO S SBFLAG=0 F LLL=0:0 S LLL=$O(^TMP($J,"PSODESPR",LLL)) Q:'LLL D
.D DEHEAD S REDT=$O(^TMP($J,"PSODES",LLL,0)),REDUZ=$O(^TMP($J,"PSODES",LLL,REDT,0)) S RESITE=$O(^TMP($J,"PSODES",LLL,REDT,REDUZ,0)) F SS=0:0 S SS=$O(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS)) Q:'SS D
..F GG=0:0 S GG=$O(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS,GG)) Q:'GG I $D(^PS(52.5,GG,0)) S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) D
...W !,$P(^PSRX(INRX,0),"^"),?20,$P($G(^DPT(+$P(^PSRX(INRX,0),"^",2),0)),"^"),?60,$S($P($G(^PS(52.5,GG,0)),"^",5):"(PARTIAL)",$P($G(^(0)),"^",12):"(REPRINT)",1:"") S SBFLAG=1
...D:$Y+5>IOSL DEHEAD
I '$G(SBFLAG) W !!,"No Rx's to print!",!
W !!,"END OF LIST"
G DEEND
DEHEAD S PSOPTIME=$O(^TMP($J,"PSODES",LLL,0)),PSOPDUZ=$O(^TMP($J,"PSODES",LLL,PSOPTIME,0)) S Y=PSOPTIME X ^DD("DD") S PSOPTIME=Y
W @IOF W !,"ORIGINALLY QUEUED FOR ",$G(PSOPTIME)," BY ",$S($D(^VA(200,+$G(PSOPDUZ),0)):$E($P(^(0),"^"),1,31),1:"UNKNOWN"),!,"RX #",?20,"PATIENT NAME",?51,"SUSPENSE BATCH ",LLL,! F ZZZZ=1:1:78 W "-"
Q
DEEND W @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J,"PSODES"),^TMP($J,"PSODESPR"),SBFLAG,LLL,ZZZZ,REDT,REDUZ,RESITE,SS,GG,INRX,PSOPTIME,PSOPDUZ
Q
MSQ W !!,"REPORT of batched Rx's queued to print!",! Q
MSNQ W !!,"REPORT of batched Rx's being sent to print!",! Q
GETN ;
S NM1=$O(^TMP($J,"PSOHLRES",LLL,0)),NM2=$O(^TMP($J,"PSOHLRES",LLL,NM1,PSOSITE,0)),NM3=$O(^PS(52.51,"AS",NM1,PSOSITE,NM2,0))
S HLZNAME=$P($G(^DPT(+$P($G(^PS(52.51,+$G(NM3),0)),"^",2),0)),"^")
Q
GETPPL ;
K PPLX,RXPRX
N PPLDT,PPLDV,PPLDZ,PPLOP,PPLOOP,PPLRXN,PDEAD,PCOMM,PMEDX,DFN,PDCT
F PPLOP=0:0 S PPLOP=$O(^TMP($J,"PSOHLSPR",PPLOP)) Q:'PPLOP D
.W "." S PPLDT=$O(^TMP($J,"PSOHLRES",PPLOP,0)),PPLDZ=$O(^TMP($J,"PSOHLRES",PPLOP,PPLDT,PSOSITE,0))
.S (PDEAD,PDCT)=0 F PPLOOP=0:0 S PPLOOP=$O(^PS(52.51,"AS",PPLDT,PSOSITE,PPLDZ,PPLOOP)) Q:'PPLOOP!($G(PDEAD)) D
..S PPLRXN=$P($G(^PS(52.51,PPLOOP,0)),"^"),DFN=+$P($G(^(0)),"^",2) I PPLRXN D
...S PDEAD=0 I '$G(PDCT) D DEM^VADPT S PDCT=PDCT+1 I $P(VADM(6),"^",2)]"" S PDEAD=1
...Q:$G(PDEAD)
...I $D(^PSRX(PPLRXN,0)) I $P($G(^PSRX(PPLRXN,"STA")),"^")=0!($P($G(^("STA")),"^")=5) D
....S PMEDX=0 D MEDEX Q:PMEDX
....I $G(PPLX(DFN))="" S PPLX(DFN)=PPLRXN_"," D PART Q
....S PPLX(DFN)=PPLX(DFN)_PPLRXN_"," D PART
Q
MEDEX ;
I DT>$P($G(^PSRX(PPLRXN,2)),"^",6) D
.S PMEDX=1
.S $P(^PSRX(PPLRXN,"STA"),"^")=11,PCOMM="Medication expired on "_$E($P($G(^PSRX(PPLRXN,2)),"^",6),4,5)_"-"_$E($P($G(^PSRX(PPLRXN,2)),"^",6),6,7)_"-"_$E($P($G(^PSRX(PPLRXN,2)),"^",6),2,3) D EN^PSOHLSN1(PPLRXN,"SC","ZE",PCOMM)
Q
PART ;
I $P($G(^PS(52.51,PPLOOP,0)),"^",8)="P",$P($G(^(0)),"^",9) S RXPRX(DFN,PPLRXN)=$P(^(0),"^",9)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOEXBCH 4988 printed Sep 23, 2025@20:05:43 Page 2
PSOEXBCH ;BIR/RTR-print external interface list to a printer ;1/1/96
+1 ;;7.0;OUTPATIENT PHARMACY;**26**;DEC 1997
+2 ;External reference to ^PSDRUG supported by DBIA 221
QUE KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF POP
WRITE !,"NOTHING PRINTED"
QUIT
+1 IF $EXTRACT(IOST)'["P"
WRITE !!,"This report must be sent to a printer!",!
GOTO QUE
+2 IF $DATA(IO("Q"))
SET ZTRTN="LIST^PSOEXBCH"
SET ZTDESC="Report of printed interface batches"
SET ZTSAVE("^TMP($J,""PSOHLRES"",")=""
SET ZTSAVE("^TMP($J,""PSOHLSPR"",")=""
SET ZTSAVE("PSOSITE")=""
DO ^%ZTLOAD
DO MSQ
DO ^%ZISC
QUIT
+3 DO MSNQ
LIST USE IO
KILL PSOIOF
SET SBFLAG=0
FOR LLL=0:0
SET LLL=$ORDER(^TMP($JOB,"PSOHLSPR",LLL))
if 'LLL
QUIT
DO GETN
Begin DoDot:1
+1 DO HEAD
SET REDT=$ORDER(^TMP($JOB,"PSOHLRES",LLL,0))
SET REDUZ=$ORDER(^TMP($JOB,"PSOHLRES",LLL,REDT,PSOSITE,0))
FOR SS=0:0
SET SS=$ORDER(^PS(52.51,"AS",REDT,PSOSITE,REDUZ,SS))
if 'SS
QUIT
Begin DoDot:2
+2 IF $DATA(^PS(52.51,SS,0))
IF $PIECE($GET(^(0)),"^",11)=PSOSITE
SET INRX=$PIECE(^(0),"^")
IF $DATA(^PSRX(INRX,0))
Begin DoDot:3
+3 ;D STAT^PSOEXRST
+4 SET HLZZNAME=$PIECE($GET(^DPT(+$PIECE($GET(^PSRX(INRX,0)),"^",2),0)),"^")
+5 SET HLZZDRUG=$PIECE($GET(^PSDRUG(+$PIECE($GET(^PSRX(INRX,0)),"^",6),0)),"^")
SET HLZZDRUL=$LENGTH($GET(HLZZDRUG))
+6 WRITE !,$PIECE(^PSRX(INRX,0),"^"),?13,$GET(HLZZNAME)
SET SBFLAG=1
+7 IF +$GET(HLZZDRUL)<37
WRITE ?44,$GET(HLZZDRUG)
+8 IF +$GET(HLZZDRUL)>36
WRITE !?38,$GET(HLZZDRUG)
+9 IF $Y+5>IOSL
IF $ORDER(^PS(52.51,"AS",REDT,PSOSITE,REDUZ,SS))
SET PSOIOF=1
DO HEAD
KILL PSOIOF
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF '$GET(SBFLAG)
WRITE !!,"No Rx's to print!",!
+11 WRITE !!,"END OF LIST"
+12 GOTO END
HEAD SET PSOPTIME=$ORDER(^TMP($JOB,"PSOHLRES",LLL,0))
SET PSOPDUZ=$ORDER(^TMP($JOB,"PSOHLRES",LLL,PSOPTIME,PSOSITE,0))
SET Y=PSOPTIME
XECUTE ^DD("DD")
SET PSOPTIME=Y
+1 IF '$GET(SBFLAG)
WRITE @IOF
+2 IF $GET(PSOIOF)
WRITE @IOF
+3 IF '$GET(PSOIOF)
IF $GET(SBFLAG)
IF $Y+5>IOSL
WRITE @IOF
+4 IF $GET(SBFLAG)
WRITE !
+5 WRITE !!,"ORIGINALLY QUEUED FOR ",$GET(PSOPTIME)," BY ",$SELECT($DATA(^VA(200,+$GET(PSOPDUZ),0)):$EXTRACT($PIECE(^(0),"^"),1,31),1:"UNKNOWN"),!,"RX #",?13,"PATIENT NAME",?44,"BATCH ",LLL,!
FOR ZZZZ=1:1:78
WRITE "-"
+6 QUIT
END WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB,"PSOHLRES"),^TMP($JOB,"PSOHLSPR"),REDT,REDUZ,SS,GG,INRX,LLL,ZZZZ,PSOPTIME,PSOPDUZ,PSEXSTAT,PSX,HLZZDRUG,HLZZNAME,HLZZDRUL,PSOIOF
QUIT
DEQUE KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF POP
QUIT
+1 IF $EXTRACT(IOST)'["P"
WRITE !!,"This report must be sent to a printer!",!
GOTO DEQUE
+2 IF $DATA(IO("Q"))
SET ZTRTN="DELIST^PSOSUBCH"
SET ZTDESC="Report of printed suspense batch"
SET ZTSAVE("^TMP($J,""PSODES"",")=""
SET ZTSAVE("^TMP($J,""PSODESPR"",")=""
SET ZTSAVE("PSOSITE")=""
DO ^%ZTLOAD
DO MSQ
DO ^%ZISC
QUIT
+3 DO MSNQ
DELIST USE IO
SET SBFLAG=0
FOR LLL=0:0
SET LLL=$ORDER(^TMP($JOB,"PSODESPR",LLL))
if 'LLL
QUIT
Begin DoDot:1
+1 DO DEHEAD
SET REDT=$ORDER(^TMP($JOB,"PSODES",LLL,0))
SET REDUZ=$ORDER(^TMP($JOB,"PSODES",LLL,REDT,0))
SET RESITE=$ORDER(^TMP($JOB,"PSODES",LLL,REDT,REDUZ,0))
FOR SS=0:0
SET SS=$ORDER(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS))
if 'SS
QUIT
Begin DoDot:2
+2 FOR GG=0:0
SET GG=$ORDER(^PS(52.5,"AS",REDT,REDUZ,RESITE,SS,GG))
if 'GG
QUIT
IF $DATA(^PS(52.5,GG,0))
SET INRX=$PIECE(^(0),"^")
IF $DATA(^PSRX(INRX,0))
Begin DoDot:3
+3 WRITE !,$PIECE(^PSRX(INRX,0),"^"),?20,$PIECE($GET(^DPT(+$PIECE(^PSRX(INRX,0),"^",2),0)),"^"),?60,$SELECT($PIECE($GET(^PS(52.5,GG,0)),"^",5):"(PARTIAL)",$PIECE($GET(^(0)),"^",12):"(REPRINT)",1:"")
SET SBFLAG=1
+4 if $Y+5>IOSL
DO DEHEAD
End DoDot:3
End DoDot:2
End DoDot:1
+5 IF '$GET(SBFLAG)
WRITE !!,"No Rx's to print!",!
+6 WRITE !!,"END OF LIST"
+7 GOTO DEEND
DEHEAD SET PSOPTIME=$ORDER(^TMP($JOB,"PSODES",LLL,0))
SET PSOPDUZ=$ORDER(^TMP($JOB,"PSODES",LLL,PSOPTIME,0))
SET Y=PSOPTIME
XECUTE ^DD("DD")
SET PSOPTIME=Y
+1 WRITE @IOF
WRITE !,"ORIGINALLY QUEUED FOR ",$GET(PSOPTIME)," BY ",$SELECT($DATA(^VA(200,+$GET(PSOPDUZ),0)):$EXTRACT($PIECE(^(0),"^"),1,31),1:"UNKNOWN"),!,"RX #",?20,"PATIENT NAME",?51,"SUSPENSE BATCH ",LLL,!
FOR ZZZZ=1:1:78
WRITE "-"
+2 QUIT
DEEND WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB,"PSODES"),^TMP($JOB,"PSODESPR"),SBFLAG,LLL,ZZZZ,REDT,REDUZ,RESITE,SS,GG,INRX,PSOPTIME,PSOPDUZ
+1 QUIT
MSQ WRITE !!,"REPORT of batched Rx's queued to print!",!
QUIT
MSNQ WRITE !!,"REPORT of batched Rx's being sent to print!",!
QUIT
GETN ;
+1 SET NM1=$ORDER(^TMP($JOB,"PSOHLRES",LLL,0))
SET NM2=$ORDER(^TMP($JOB,"PSOHLRES",LLL,NM1,PSOSITE,0))
SET NM3=$ORDER(^PS(52.51,"AS",NM1,PSOSITE,NM2,0))
+2 SET HLZNAME=$PIECE($GET(^DPT(+$PIECE($GET(^PS(52.51,+$GET(NM3),0)),"^",2),0)),"^")
+3 QUIT
GETPPL ;
+1 KILL PPLX,RXPRX
+2 NEW PPLDT,PPLDV,PPLDZ,PPLOP,PPLOOP,PPLRXN,PDEAD,PCOMM,PMEDX,DFN,PDCT
+3 FOR PPLOP=0:0
SET PPLOP=$ORDER(^TMP($JOB,"PSOHLSPR",PPLOP))
if 'PPLOP
QUIT
Begin DoDot:1
+4 WRITE "."
SET PPLDT=$ORDER(^TMP($JOB,"PSOHLRES",PPLOP,0))
SET PPLDZ=$ORDER(^TMP($JOB,"PSOHLRES",PPLOP,PPLDT,PSOSITE,0))
+5 SET (PDEAD,PDCT)=0
FOR PPLOOP=0:0
SET PPLOOP=$ORDER(^PS(52.51,"AS",PPLDT,PSOSITE,PPLDZ,PPLOOP))
if 'PPLOOP!($GET(PDEAD))
QUIT
Begin DoDot:2
+6 SET PPLRXN=$PIECE($GET(^PS(52.51,PPLOOP,0)),"^")
SET DFN=+$PIECE($GET(^(0)),"^",2)
IF PPLRXN
Begin DoDot:3
+7 SET PDEAD=0
IF '$GET(PDCT)
DO DEM^VADPT
SET PDCT=PDCT+1
IF $PIECE(VADM(6),"^",2)]""
SET PDEAD=1
+8 if $GET(PDEAD)
QUIT
+9 IF $DATA(^PSRX(PPLRXN,0))
IF $PIECE($GET(^PSRX(PPLRXN,"STA")),"^")=0!($PIECE($GET(^("STA")),"^")=5)
Begin DoDot:4
+10 SET PMEDX=0
DO MEDEX
if PMEDX
QUIT
+11 IF $GET(PPLX(DFN))=""
SET PPLX(DFN)=PPLRXN_","
DO PART
QUIT
+12 SET PPLX(DFN)=PPLX(DFN)_PPLRXN_","
DO PART
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
MEDEX ;
+1 IF DT>$PIECE($GET(^PSRX(PPLRXN,2)),"^",6)
Begin DoDot:1
+2 SET PMEDX=1
+3 SET $PIECE(^PSRX(PPLRXN,"STA"),"^")=11
SET PCOMM="Medication expired on "_$EXTRACT($PIECE($GET(^PSRX(PPLRXN,2)),"^",6),4,5)_"-"_$EXTRACT($PIECE($GET(^PSRX(PPLRXN,2)),"^",6),6,7)_"-"_$EXTRACT($PIECE($GET(^PSRX(PPLRXN,2)),"^",6),2,3)
DO EN^PSOHLSN1(PPLRXN,"SC","ZE",PCOMM)
End DoDot:1
+4 QUIT
PART ;
+1 IF $PIECE($GET(^PS(52.51,PPLOOP,0)),"^",8)="P"
IF $PIECE($GET(^(0)),"^",9)
SET RXPRX(DFN,PPLRXN)=$PIECE(^(0),"^",9)
+2 QUIT
