source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOARCTG.m@ 1093

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1PSOARCTG ;BHAM ISC/LGH - gather tape info ; 07/07/92
2 ;;7.0;OUTPATIENT PHARMACY;**10**;DEC 1997
3AC S DFN=DA,TA=$S($D(PSOAT):1,1:0) K T D ADD^VADPT,DEM^VADPT,ELIG^VADPT
4 S I=$P($G(VADM(3)),"^")
5 S T(1)=$G(VADM(1))_"^"_$P($G(VADM(2)),"^")_"^"_$P($G(VAEL(1)),"^",2)
6 S T(1)=T(1)_"^"_$G(VAPA(1))_"^"_$S(I:$E(I,4,5)_"-"_$E(I,6,7)_"-"_(1700+$E(I,1,3)),1:"UNKNOWN")_"^"_$S($G(VAPA(8)):VAPA(8),1:"")
7 S T(1)=T(1)_"^"_$G(VAPA(4))_"^"_$P($G(VAPA(5)),"^",2)_"^"_$G(VAPA(6))_"^"
8 I $D(^PS(55,DFN,0)),+$P(^(0),"^",2) S T(1)=T(1)_1_"^" S:+$P(^(0),"^",4) T(1)=T(1)_1
9 S T(2)="" I $D(^PS(55,DFN,1)),^(1)]"" S T(2)=T(2)_^(1)
10 S T(2)=T(2)_"^^^^",PSLC=0 G MA:'$D(^DPT(DFN,.17)) G MA:$P(^(.17),"^",2)'="I" S TZ=1 G MA:'$D(^DPT(DFN,.372))
11 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:+I'>0 S I1=$S($D(^(I,0)):^(0),1:""),PSDIS=$S($D(^DIC(31,+I1,0)):^(0),1:""),PSPRCNT=$P(I1,"^",2),T(2,TZ)=PSDIS_"^"_PSPRCNT,TZ=TZ+1
12 S T(2)=$P(T(2),"^")_"^"_(TZ-1)_"^"_$P(T(2),"^",3,99)
13MA S GMRA="0^0^111" D ^GMRADPT
14 G END:'$G(GMRAL) S TZ=1 F I1=0:0 S I1=$O(GMRAL(I1)) Q:'I1 S T(3,TZ)=$P($G(GMRAL(I1)),"^",2),TZ=TZ+1
15 S T(2)=$P(T(2),"^",1,2)_"^"_(TZ-1)_"^"_$P(T(2),"^",4,99)
16END D KVA^VADPT K GMRAL,TZ,SC
17Q Q
18CMOP ;Called by ACT+1^PSOARX Prints CMOP Data for "Display Archived Rx's"
19 F Z1=0:0 S Z1=$O(^PSRX(DA,4,Z1)) Q:(+$G(Z1)<1) S ZZ1=^(Z1,0) D
20 .I $Y'>(PSOACPL-20),(Z1=1) D C1
21 .D:$Y>(PSOACPL-20) HD1,C1
22 .S Y=$P($G(ZZ1),"^",5) I Y X ^DD("DD") S $P(ZZ1,"^",5)=$P(Y,"@") K Y
23 .S ZST=+$P($G(ZZ1),"^",4) I $G(ZST)]"" S $P(ZZ1,"^",4)=$S(ZST=0:"TRANS",ZST=1:"DISP",ZST=2:"RETRANS",ZST=3:"NOT DISP",1:"UNKNOWN")
24 .W !,Z1,?3,$P(ZZ1,"^")_"-"_$P(ZZ1,"^",2)
25 .W ?22,$J($P(ZZ1,"^",3),3),?30,$P(ZZ1,"^",4)
26 .S ZZ2=$G(^PSRX(DA,4,Z1,1)) I $G(ZZ2)]"" D
27 ..S Y=$P(ZZ2,"^",2) I $G(Y)]"" X ^DD("DD") S $P(ZZ2,"^",2)=$P(Y,"@") K Y
28 ..W ?40,$P(ZZ2,"^",2),?52,$E($P(ZZ2,"^",3),1,20),?74,$E($P(ZZ2,"^",4),1,20) K ZZ2
29 .W ?96,$S($P(ZZ1,"^",8)]"":"NDC "_$P(ZZ1,"^",8),$P(ZZ1,"^",5)]"":"CAN DT/REASON "_$P(ZZ1,"^",5)_" "_$E($G(^PSRX(DA,4,Z1,1)),1,20),1:"")
30 K ZZ1,Z1,ZST,ZZ2
31 F Z1=0:0 S Z1=$O(^PSRX(DA,5,Z1)) Q:'Z1 S ZZ1=^(Z1,0) D
32 .I $Y'>(PSOACPL-20),(Z1=1) D C2
33 .D:$Y>(PSOACPL-20) HD1,C2
34 .S Y=$P($G(ZZ1),"^",2) I Y X ^DD("DD") S $P(ZZ1,"^",2)=Y
35 .W !,Z1,?5,$P(ZZ1,"^"),?51,$J($P(ZZ1,"^",2),12),?71,$J($P(ZZ1,"^",3),3)
36 K Z1,ZZ1,ZST
37 Q
38C1 W !!,"CMOP EVENT LOG"
39 W !,"#",?5,"TRANS #",?20,"RX REF",?30,"STATUS",?40,"SHIP DATE",?52,"CARRIER",?76,"PACKAGE ID",?100,"REMARKS"
40 W ! F I=1:1:120 W "="
41 Q
42C2 W !!,"CMOP LOT#/EXPIRATION DATE LOG"
43 W !,"#",?15,"LOT #",?49,"EXPIRATION DATE",?70,"RX REF"
44 W ! F I=1:1:80 W "="
45 Q
46HD1 W @PSOACPF,?(66-($L(PSOACDS)\2)),PSOACDS,?112,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3),?122,"PAGE ",PSOAPG S PSOAPG=PSOAPG+1 W !
Note: See TracBrowser for help on using the repository browser.