source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOEXBCH.m@ 1452

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