PSOARCTG ;BHAM ISC/LGH - gather tape info ; 07/07/92
;;7.0;OUTPATIENT PHARMACY;**10**;DEC 1997
AC S DFN=DA,TA=$S($D(PSOAT):1,1:0) K T D ADD^VADPT,DEM^VADPT,ELIG^VADPT
S I=$P($G(VADM(3)),"^")
S T(1)=$G(VADM(1))_"^"_$P($G(VADM(2)),"^")_"^"_$P($G(VAEL(1)),"^",2)
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:"")
S T(1)=T(1)_"^"_$G(VAPA(4))_"^"_$P($G(VAPA(5)),"^",2)_"^"_$G(VAPA(6))_"^"
I $D(^PS(55,DFN,0)),+$P(^(0),"^",2) S T(1)=T(1)_1_"^" S:+$P(^(0),"^",4) T(1)=T(1)_1
S T(2)="" I $D(^PS(55,DFN,1)),^(1)]"" S T(2)=T(2)_^(1)
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))
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
S T(2)=$P(T(2),"^")_"^"_(TZ-1)_"^"_$P(T(2),"^",3,99)
MA S GMRA="0^0^111" D ^GMRADPT
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
S T(2)=$P(T(2),"^",1,2)_"^"_(TZ-1)_"^"_$P(T(2),"^",4,99)
END D KVA^VADPT K GMRAL,TZ,SC
Q Q
CMOP ;Called by ACT+1^PSOARX Prints CMOP Data for "Display Archived Rx's"
F Z1=0:0 S Z1=$O(^PSRX(DA,4,Z1)) Q:(+$G(Z1)<1) S ZZ1=^(Z1,0) D
.I $Y'>(PSOACPL-20),(Z1=1) D C1
.D:$Y>(PSOACPL-20) HD1,C1
.S Y=$P($G(ZZ1),"^",5) I Y X ^DD("DD") S $P(ZZ1,"^",5)=$P(Y,"@") K Y
.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")
.W !,Z1,?3,$P(ZZ1,"^")_"-"_$P(ZZ1,"^",2)
.W ?22,$J($P(ZZ1,"^",3),3),?30,$P(ZZ1,"^",4)
.S ZZ2=$G(^PSRX(DA,4,Z1,1)) I $G(ZZ2)]"" D
..S Y=$P(ZZ2,"^",2) I $G(Y)]"" X ^DD("DD") S $P(ZZ2,"^",2)=$P(Y,"@") K Y
..W ?40,$P(ZZ2,"^",2),?52,$E($P(ZZ2,"^",3),1,20),?74,$E($P(ZZ2,"^",4),1,20) K ZZ2
.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:"")
K ZZ1,Z1,ZST,ZZ2
F Z1=0:0 S Z1=$O(^PSRX(DA,5,Z1)) Q:'Z1 S ZZ1=^(Z1,0) D
.I $Y'>(PSOACPL-20),(Z1=1) D C2
.D:$Y>(PSOACPL-20) HD1,C2
.S Y=$P($G(ZZ1),"^",2) I Y X ^DD("DD") S $P(ZZ1,"^",2)=Y
.W !,Z1,?5,$P(ZZ1,"^"),?51,$J($P(ZZ1,"^",2),12),?71,$J($P(ZZ1,"^",3),3)
K Z1,ZZ1,ZST
Q
C1 W !!,"CMOP EVENT LOG"
W !,"#",?5,"TRANS #",?20,"RX REF",?30,"STATUS",?40,"SHIP DATE",?52,"CARRIER",?76,"PACKAGE ID",?100,"REMARKS"
W ! F I=1:1:120 W "="
Q
C2 W !!,"CMOP LOT#/EXPIRATION DATE LOG"
W !,"#",?15,"LOT #",?49,"EXPIRATION DATE",?70,"RX REF"
W ! F I=1:1:80 W "="
Q
HD1 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 !
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCTG 2737 printed Oct 16, 2024@18:25:03 Page 2
PSOARCTG ;BHAM ISC/LGH - gather tape info ; 07/07/92
+1 ;;7.0;OUTPATIENT PHARMACY;**10**;DEC 1997
AC SET DFN=DA
SET TA=$SELECT($DATA(PSOAT):1,1:0)
KILL T
DO ADD^VADPT
DO DEM^VADPT
DO ELIG^VADPT
+1 SET I=$PIECE($GET(VADM(3)),"^")
+2 SET T(1)=$GET(VADM(1))_"^"_$PIECE($GET(VADM(2)),"^")_"^"_$PIECE($GET(VAEL(1)),"^",2)
+3 SET T(1)=T(1)_"^"_$GET(VAPA(1))_"^"_$SELECT(I:$EXTRACT(I,4,5)_"-"_$EXTRACT(I,6,7)_"-"_(1700+$EXTRACT(I,1,3)),1:"UNKNOWN")_"^"_$SELECT($GET(VAPA(8)):VAPA(8),1:"")
+4 SET T(1)=T(1)_"^"_$GET(VAPA(4))_"^"_$PIECE($GET(VAPA(5)),"^",2)_"^"_$GET(VAPA(6))_"^"
+5 IF $DATA(^PS(55,DFN,0))
IF +$PIECE(^(0),"^",2)
SET T(1)=T(1)_1_"^"
if +$PIECE(^(0),"^",4)
SET T(1)=T(1)_1
+6 SET T(2)=""
IF $DATA(^PS(55,DFN,1))
IF ^(1)]""
SET T(2)=T(2)_^(1)
+7 SET T(2)=T(2)_"^^^^"
SET PSLC=0
if '$DATA(^DPT(DFN,.17))
GOTO MA
if $PIECE(^(.17),"^",2)'="I"
GOTO MA
SET TZ=1
if '$DATA(^DPT(DFN,.372))
GOTO MA
+8 FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if +I'>0
QUIT
SET I1=$SELECT($DATA(^(I,0)):^(0),1:"")
SET PSDIS=$SELECT($DATA(^DIC(31,+I1,0)):^(0),1:"")
SET PSPRCNT=$PIECE(I1,"^",2)
SET T(2,TZ)=PSDIS_"^"_PSPRCNT
SET TZ=TZ+1
+9 SET T(2)=$PIECE(T(2),"^")_"^"_(TZ-1)_"^"_$PIECE(T(2),"^",3,99)
MA SET GMRA="0^0^111"
DO ^GMRADPT
+1 if '$GET(GMRAL)
GOTO END
SET TZ=1
FOR I1=0:0
SET I1=$ORDER(GMRAL(I1))
if 'I1
QUIT
SET T(3,TZ)=$PIECE($GET(GMRAL(I1)),"^",2)
SET TZ=TZ+1
+2 SET T(2)=$PIECE(T(2),"^",1,2)_"^"_(TZ-1)_"^"_$PIECE(T(2),"^",4,99)
END DO KVA^VADPT
KILL GMRAL,TZ,SC
Q QUIT
CMOP ;Called by ACT+1^PSOARX Prints CMOP Data for "Display Archived Rx's"
+1 FOR Z1=0:0
SET Z1=$ORDER(^PSRX(DA,4,Z1))
if (+$GET(Z1)<1)
QUIT
SET ZZ1=^(Z1,0)
Begin DoDot:1
+2 IF $Y'>(PSOACPL-20)
IF (Z1=1)
DO C1
+3 if $Y>(PSOACPL-20)
DO HD1
DO C1
+4 SET Y=$PIECE($GET(ZZ1),"^",5)
IF Y
XECUTE ^DD("DD")
SET $PIECE(ZZ1,"^",5)=$PIECE(Y,"@")
KILL Y
+5 SET ZST=+$PIECE($GET(ZZ1),"^",4)
IF $GET(ZST)]""
SET $PIECE(ZZ1,"^",4)=$SELECT(ZST=0:"TRANS",ZST=1:"DISP",ZST=2:"RETRANS",ZST=3:"NOT DISP",1:"UNKNOWN")
+6 WRITE !,Z1,?3,$PIECE(ZZ1,"^")_"-"_$PIECE(ZZ1,"^",2)
+7 WRITE ?22,$JUSTIFY($PIECE(ZZ1,"^",3),3),?30,$PIECE(ZZ1,"^",4)
+8 SET ZZ2=$GET(^PSRX(DA,4,Z1,1))
IF $GET(ZZ2)]""
Begin DoDot:2
+9 SET Y=$PIECE(ZZ2,"^",2)
IF $GET(Y)]""
XECUTE ^DD("DD")
SET $PIECE(ZZ2,"^",2)=$PIECE(Y,"@")
KILL Y
+10 WRITE ?40,$PIECE(ZZ2,"^",2),?52,$EXTRACT($PIECE(ZZ2,"^",3),1,20),?74,$EXTRACT($PIECE(ZZ2,"^",4),1,20)
KILL ZZ2
End DoDot:2
+11 WRITE ?96,$SELECT($PIECE(ZZ1,"^",8)]"":"NDC "_$PIECE(ZZ1,"^",8),$PIECE(ZZ1,"^",5)]"":"CAN DT/REASON "_$PIECE(ZZ1,"^",5)_" "_$EXTRACT($GET(^PSRX(DA,4,Z1,1)),1,20),1:"")
End DoDot:1
+12 KILL ZZ1,Z1,ZST,ZZ2
+13 FOR Z1=0:0
SET Z1=$ORDER(^PSRX(DA,5,Z1))
if 'Z1
QUIT
SET ZZ1=^(Z1,0)
Begin DoDot:1
+14 IF $Y'>(PSOACPL-20)
IF (Z1=1)
DO C2
+15 if $Y>(PSOACPL-20)
DO HD1
DO C2
+16 SET Y=$PIECE($GET(ZZ1),"^",2)
IF Y
XECUTE ^DD("DD")
SET $PIECE(ZZ1,"^",2)=Y
+17 WRITE !,Z1,?5,$PIECE(ZZ1,"^"),?51,$JUSTIFY($PIECE(ZZ1,"^",2),12),?71,$JUSTIFY($PIECE(ZZ1,"^",3),3)
End DoDot:1
+18 KILL Z1,ZZ1,ZST
+19 QUIT
C1 WRITE !!,"CMOP EVENT LOG"
+1 WRITE !,"#",?5,"TRANS #",?20,"RX REF",?30,"STATUS",?40,"SHIP DATE",?52,"CARRIER",?76,"PACKAGE ID",?100,"REMARKS"
+2 WRITE !
FOR I=1:1:120
WRITE "="
+3 QUIT
C2 WRITE !!,"CMOP LOT#/EXPIRATION DATE LOG"
+1 WRITE !,"#",?15,"LOT #",?49,"EXPIRATION DATE",?70,"RX REF"
+2 WRITE !
FOR I=1:1:80
WRITE "="
+3 QUIT
HD1 WRITE @PSOACPF,?(66-($LENGTH(PSOACDS)\2)),PSOACDS,?112,$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3),?122,"PAGE ",PSOAPG
SET PSOAPG=PSOAPG+1
WRITE !
