- 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 Feb 18, 2025@23:50:51 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 !