- 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
- 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
