source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOEXBCH.m@ 762

Last change on this file since 762 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PSOEXBCH ;BIR/RTR-print external interface list to a printer ;1/1/96
2 ;;7.0;OUTPATIENT PHARMACY;**26**;DEC 1997
3 ;External reference to ^PSDRUG supported by DBIA 221
4QUE K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP W !,"NOTHING PRINTED" Q
5 I $E(IOST)'["P" W !!,"This report must be sent to a printer!",! G QUE
6 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
7 D MSNQ
8LIST U IO K PSOIOF S SBFLAG=0 F LLL=0:0 S LLL=$O(^TMP($J,"PSOHLSPR",LLL)) Q:'LLL D GETN D
9 .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
10 ..I $D(^PS(52.51,SS,0)),$P($G(^(0)),"^",11)=PSOSITE S INRX=$P(^(0),"^") I $D(^PSRX(INRX,0)) D
11 ...;D STAT^PSOEXRST
12 ...S HLZZNAME=$P($G(^DPT(+$P($G(^PSRX(INRX,0)),"^",2),0)),"^")
13 ...S HLZZDRUG=$P($G(^PSDRUG(+$P($G(^PSRX(INRX,0)),"^",6),0)),"^"),HLZZDRUL=$L($G(HLZZDRUG))
14 ...W !,$P(^PSRX(INRX,0),"^"),?13,$G(HLZZNAME) S SBFLAG=1
15 ...I +$G(HLZZDRUL)<37 W ?44,$G(HLZZDRUG)
16 ...I +$G(HLZZDRUL)>36 W !?38,$G(HLZZDRUG)
17 ...I $Y+5>IOSL,$O(^PS(52.51,"AS",REDT,PSOSITE,REDUZ,SS)) S PSOIOF=1 D HEAD K PSOIOF
18 I '$G(SBFLAG) W !!,"No Rx's to print!",!
19 W !!,"END OF LIST"
20 G END
21HEAD 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
22 I '$G(SBFLAG) W @IOF
23 I $G(PSOIOF) W @IOF
24 I '$G(PSOIOF),$G(SBFLAG),$Y+5>IOSL W @IOF
25 I $G(SBFLAG) W !
26 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 "-"
27 Q
28END 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
29DEQUE K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP Q
30 I $E(IOST)'["P" W !!,"This report must be sent to a printer!",! G DEQUE
31 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
32 D MSNQ
33DELIST U IO S SBFLAG=0 F LLL=0:0 S LLL=$O(^TMP($J,"PSODESPR",LLL)) Q:'LLL D
34 .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
35 ..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
36 ...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
37 ...D:$Y+5>IOSL DEHEAD
38 I '$G(SBFLAG) W !!,"No Rx's to print!",!
39 W !!,"END OF LIST"
40 G DEEND
41DEHEAD 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
42 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 "-"
43 Q
44DEEND 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
45 Q
46MSQ W !!,"REPORT of batched Rx's queued to print!",! Q
47MSNQ W !!,"REPORT of batched Rx's being sent to print!",! Q
48GETN ;
49 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))
50 S HLZNAME=$P($G(^DPT(+$P($G(^PS(52.51,+$G(NM3),0)),"^",2),0)),"^")
51 Q
52GETPPL ;
53 K PPLX,RXPRX
54 N PPLDT,PPLDV,PPLDZ,PPLOP,PPLOOP,PPLRXN,PDEAD,PCOMM,PMEDX,DFN,PDCT
55 F PPLOP=0:0 S PPLOP=$O(^TMP($J,"PSOHLSPR",PPLOP)) Q:'PPLOP D
56 .W "." S PPLDT=$O(^TMP($J,"PSOHLRES",PPLOP,0)),PPLDZ=$O(^TMP($J,"PSOHLRES",PPLOP,PPLDT,PSOSITE,0))
57 .S (PDEAD,PDCT)=0 F PPLOOP=0:0 S PPLOOP=$O(^PS(52.51,"AS",PPLDT,PSOSITE,PPLDZ,PPLOOP)) Q:'PPLOOP!($G(PDEAD)) D
58 ..S PPLRXN=$P($G(^PS(52.51,PPLOOP,0)),"^"),DFN=+$P($G(^(0)),"^",2) I PPLRXN D
59 ...S PDEAD=0 I '$G(PDCT) D DEM^VADPT S PDCT=PDCT+1 I $P(VADM(6),"^",2)]"" S PDEAD=1
60 ...Q:$G(PDEAD)
61 ...I $D(^PSRX(PPLRXN,0)) I $P($G(^PSRX(PPLRXN,"STA")),"^")=0!($P($G(^("STA")),"^")=5) D
62 ....S PMEDX=0 D MEDEX Q:PMEDX
63 ....I $G(PPLX(DFN))="" S PPLX(DFN)=PPLRXN_"," D PART Q
64 ....S PPLX(DFN)=PPLX(DFN)_PPLRXN_"," D PART
65 Q
66MEDEX ;
67 I DT>$P($G(^PSRX(PPLRXN,2)),"^",6) D
68 .S PMEDX=1
69 .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)
70 Q
71PART ;
72 I $P($G(^PS(52.51,PPLOOP,0)),"^",8)="P",$P($G(^(0)),"^",9) S RXPRX(DFN,PPLRXN)=$P(^(0),"^",9)
73 Q
Note: See TracBrowser for help on using the repository browser.