PSXVIEW ;BIR/HTW-CMOP Data for View Prescription ;[ 02/02/98 7:46 AM ]
;;2.0;CMOP;**11**;11 Apr 97
S PSXM=$O(^PSRX(DA,4,0)) G:'$G(PSXM) FINI K PSXM
D PAGE Q:$G(ANS)]""
FOUR ; Get data from event multiple
D HEADER
F PSXA=0:0 S PSXA=$O(^PSRX(DA,4,PSXA)) Q:'PSXA!($G(ANS)["^") S PSX4=^(PSXA,0) D
.D FIX
.I $Y>20 D PAGE Q:$G(ANS)["^" D HEADER
.D PRINT Q:$G(ANS)["^"
D JUMP Q:$G(ANS)["^"
D PSXLOT
FINI K ANS,Y,%,I,Z,PSXLOT,PSXL,PSX4,F,PSXA,C,ER,PSXFIL,PSX4,PSXREA,PSXVID
K PSXREL,PSXTRDT,PSXT,PSXLOC,DTOUT,DUOUT,PSXSEQ,PSXA,PSXML,P,I1,I2
K PSXP,PSXE,PSXE1,PSXERR,PSXBAT,ZD1,ZD2,ZDT,RXREF,PSXZ,PSXTST,PSXTCAN
K PSXRDT,PSXNDC,PSXM,PSXL1,PSXCAN,PSX1,EXPDT,PSXBREF,RXREF1
Q
PRINT ;
W !!,$S($G(PSXTST)=3:PSXTCAN,$G(PSXTST)=1:$G(PSXRDT),1:$G(PSXTRDT))
W ?15,$S(PSXFIL=0:"ORIG",1:"REF "_$G(PSXFIL))
W ?22,$G(PSXBREF)
W ?36,$G(PSXT)
W ?42,$S($G(PSXTST)=3:$E($G(PSXCAN),1,35),$G(PSXNDC)]"":"NDC: "_PSXNDC,1:"")
Q
PSXLOT ;
Q:$O(^PSRX(DA,5,0))'>0
W @IOF
W "CMOP LOT#/EXPIRATION DATE LOG:"
W !,"RX REF",?20,"LOT #",?40,"EXPIRATION DATE",!
D Z1
W !
F PSXZ=0:0 S PSXZ=$O(^PSRX(DA,5,PSXZ)) Q:PSXZ']"" S PSXLOT=^(PSXZ,0) D
.S EXPDT=$P(PSXLOT,U,2)
.S EXPDT=$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_$E(EXPDT,2,3)
.S RXREF=$P(PSXLOT,U,3)
.W !,$S(RXREF=0:"ORIG",RXREF>0:"REF "_RXREF,1:""),?20,$P(PSXLOT,U),?43,EXPDT
.Q
JUMP S PSXL=22-$Y F PSXP=1:1:PSXL W !
PAGE K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or ""^"" to exit" D ^DIR K DIR S:$D(DTOUT)!($D(DUOUT)) (ANS)="^"
Q
W @IOF,"CMOP EVENT LOG:"
W !,"DATE",?15,"RX REF",?22,"TRN-ORDER #",?36,"STAT",?42,"COMMENTS"
W ! F C=1:1:79 W "="
Q
FIX ; Translate data
S PSXBAT=$P(PSX4,U),PSXSEQ=$P(PSX4,U,2)
S PSXFIL=$P(PSX4,U,3),PSXTST=$P(PSX4,U,4)
S PSXBREF=$G(PSXBAT)_"-"_$G(PSXSEQ)
S PSXZT=$P(PSX4,U,5),PSXZT1=$P(PSXZT,"."),PSXZT2=$P(PSXZT,".",2)
I $G(PSXZT)']"" K PSXZT,PSXZT1,PSXZT2 G F1
S PSXZT2=$E(PSXZT2,1,4)
S PSXZT1=$E(PSXZT1,4,5)_"/"_$E(PSXZT1,6,7)_"/"_$E(PSXZT1,2,3)
S PSXTCAN=PSXZT1_"@"_PSXZT2 K PSXZT1,PSXZT2,PSXZT
F1 S PSXNDC=$P(PSX4,U,8)
S PSXCAN=$G(^PSRX(DA,4,PSXA,1))
; Get CMOP site
S I1=$O(^PSX(550.2,"B",PSXBAT,""))
P1 ; Get transmission d/t
S ZDT=$P(^PSX(550.2,I1,0),U,6),ZD1=$P(ZDT,"."),ZD2=$P(ZDT,".",2)
S ZD2=$E(ZD2,1,4)
S ZD1=$E(ZD1,4,5)_"/"_$E(ZD1,6,7)_"/"_$E(ZD1,2,3)
S PSXTRDT=ZD1_"@"_ZD2
Q1 S:PSXTST=0 PSXT="TRAN"
I PSXTST=1 D
.I PSXFIL>0,('$D(^PSRX(DA,1,PSXFIL,0))) S PSXT="DISP REFILL DELETED" Q
.S PSX1=$S(PSXFIL=0:$P(^PSRX(DA,2),"^",13),1:$P(^PSRX(DA,1,PSXFIL,0),"^",18))
.Q:PSX1']""
.I PSX1'["." S PSXRDT=$E(PSX1,4,5)_"/"_$E(PSX1,6,7)_"/"_$E(PSX1,2,3) G SKIP
.S ZR=PSX1,ZR1=$P(ZR,"."),ZR2=$P(ZR,".",2)
.S ZR2=$E(ZR2,1,4)
.S PSXRDT=$E(ZR1,4,5)_"/"_$E(ZR1,6,7)_"/"_$E(ZR1,2,3)_"@"_ZR2
.K ZR,ZR1,ZR2
SKIP .S PSXT="DISP"
S:PSXTST=2 PSXT="RTRN"
S:PSXTST=3 PSXT="NDISP"
Q
T1 X ^DD("DD") Q
Z1 F C=1:1:79 W "="
K C
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXVIEW 2929 printed Dec 13, 2024@01:45:27 Page 2
PSXVIEW ;BIR/HTW-CMOP Data for View Prescription ;[ 02/02/98 7:46 AM ]
+1 ;;2.0;CMOP;**11**;11 Apr 97
+2 SET PSXM=$ORDER(^PSRX(DA,4,0))
if '$GET(PSXM)
GOTO FINI
KILL PSXM
+3 DO PAGE
if $GET(ANS)]""
QUIT
FOUR ; Get data from event multiple
+1 DO HEADER
+2 FOR PSXA=0:0
SET PSXA=$ORDER(^PSRX(DA,4,PSXA))
if 'PSXA!($GET(ANS)["^")
QUIT
SET PSX4=^(PSXA,0)
Begin DoDot:1
+3 DO FIX
+4 IF $Y>20
DO PAGE
if $GET(ANS)["^"
QUIT
DO HEADER
+5 DO PRINT
if $GET(ANS)["^"
QUIT
End DoDot:1
+6 DO JUMP
if $GET(ANS)["^"
QUIT
+7 DO PSXLOT
FINI KILL ANS,Y,%,I,Z,PSXLOT,PSXL,PSX4,F,PSXA,C,ER,PSXFIL,PSX4,PSXREA,PSXVID
+1 KILL PSXREL,PSXTRDT,PSXT,PSXLOC,DTOUT,DUOUT,PSXSEQ,PSXA,PSXML,P,I1,I2
+2 KILL PSXP,PSXE,PSXE1,PSXERR,PSXBAT,ZD1,ZD2,ZDT,RXREF,PSXZ,PSXTST,PSXTCAN
+3 KILL PSXRDT,PSXNDC,PSXM,PSXL1,PSXCAN,PSX1,EXPDT,PSXBREF,RXREF1
+4 QUIT
PRINT ;
+1 WRITE !!,$SELECT($GET(PSXTST)=3:PSXTCAN,$GET(PSXTST)=1:$GET(PSXRDT),1:$GET(PSXTRDT))
+2 WRITE ?15,$SELECT(PSXFIL=0:"ORIG",1:"REF "_$GET(PSXFIL))
+3 WRITE ?22,$GET(PSXBREF)
+4 WRITE ?36,$GET(PSXT)
+5 WRITE ?42,$SELECT($GET(PSXTST)=3:$EXTRACT($GET(PSXCAN),1,35),$GET(PSXNDC)]"":"NDC: "_PSXNDC,1:"")
+6 QUIT
PSXLOT ;
+1 if $ORDER(^PSRX(DA,5,0))'>0
QUIT
+2 WRITE @IOF
+3 WRITE "CMOP LOT#/EXPIRATION DATE LOG:"
+4 WRITE !,"RX REF",?20,"LOT #",?40,"EXPIRATION DATE",!
+5 DO Z1
+6 WRITE !
+7 FOR PSXZ=0:0
SET PSXZ=$ORDER(^PSRX(DA,5,PSXZ))
if PSXZ']""
QUIT
SET PSXLOT=^(PSXZ,0)
Begin DoDot:1
+8 SET EXPDT=$PIECE(PSXLOT,U,2)
+9 SET EXPDT=$EXTRACT(EXPDT,4,5)_"/"_$EXTRACT(EXPDT,6,7)_"/"_$EXTRACT(EXPDT,2,3)
+10 SET RXREF=$PIECE(PSXLOT,U,3)
+11 WRITE !,$SELECT(RXREF=0:"ORIG",RXREF>0:"REF "_RXREF,1:""),?20,$PIECE(PSXLOT,U),?43,EXPDT
+12 QUIT
End DoDot:1
JUMP SET PSXL=22-$Y
FOR PSXP=1:1:PSXL
WRITE !
PAGE KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue or ""^"" to exit"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET (ANS)="^"
+1 QUIT
+1 WRITE @IOF,"CMOP EVENT LOG:"
+2 WRITE !,"DATE",?15,"RX REF",?22,"TRN-ORDER #",?36,"STAT",?42,"COMMENTS"
+3 WRITE !
FOR C=1:1:79
WRITE "="
+4 QUIT
FIX ; Translate data
+1 SET PSXBAT=$PIECE(PSX4,U)
SET PSXSEQ=$PIECE(PSX4,U,2)
+2 SET PSXFIL=$PIECE(PSX4,U,3)
SET PSXTST=$PIECE(PSX4,U,4)
+3 SET PSXBREF=$GET(PSXBAT)_"-"_$GET(PSXSEQ)
+4 SET PSXZT=$PIECE(PSX4,U,5)
SET PSXZT1=$PIECE(PSXZT,".")
SET PSXZT2=$PIECE(PSXZT,".",2)
+5 IF $GET(PSXZT)']""
KILL PSXZT,PSXZT1,PSXZT2
GOTO F1
+6 SET PSXZT2=$EXTRACT(PSXZT2,1,4)
+7 SET PSXZT1=$EXTRACT(PSXZT1,4,5)_"/"_$EXTRACT(PSXZT1,6,7)_"/"_$EXTRACT(PSXZT1,2,3)
+8 SET PSXTCAN=PSXZT1_"@"_PSXZT2
KILL PSXZT1,PSXZT2,PSXZT
F1 SET PSXNDC=$PIECE(PSX4,U,8)
+1 SET PSXCAN=$GET(^PSRX(DA,4,PSXA,1))
+2 ; Get CMOP site
+3 SET I1=$ORDER(^PSX(550.2,"B",PSXBAT,""))
P1 ; Get transmission d/t
+1 SET ZDT=$PIECE(^PSX(550.2,I1,0),U,6)
SET ZD1=$PIECE(ZDT,".")
SET ZD2=$PIECE(ZDT,".",2)
+2 SET ZD2=$EXTRACT(ZD2,1,4)
+3 SET ZD1=$EXTRACT(ZD1,4,5)_"/"_$EXTRACT(ZD1,6,7)_"/"_$EXTRACT(ZD1,2,3)
+4 SET PSXTRDT=ZD1_"@"_ZD2
Q1 if PSXTST=0
SET PSXT="TRAN"
+1 IF PSXTST=1
Begin DoDot:1
+2 IF PSXFIL>0
IF ('$DATA(^PSRX(DA,1,PSXFIL,0)))
SET PSXT="DISP REFILL DELETED"
QUIT
+3 SET PSX1=$SELECT(PSXFIL=0:$PIECE(^PSRX(DA,2),"^",13),1:$PIECE(^PSRX(DA,1,PSXFIL,0),"^",18))
+4 if PSX1']""
QUIT
+5 IF PSX1'["."
SET PSXRDT=$EXTRACT(PSX1,4,5)_"/"_$EXTRACT(PSX1,6,7)_"/"_$EXTRACT(PSX1,2,3)
GOTO SKIP
+6 SET ZR=PSX1
SET ZR1=$PIECE(ZR,".")
SET ZR2=$PIECE(ZR,".",2)
+7 SET ZR2=$EXTRACT(ZR2,1,4)
+8 SET PSXRDT=$EXTRACT(ZR1,4,5)_"/"_$EXTRACT(ZR1,6,7)_"/"_$EXTRACT(ZR1,2,3)_"@"_ZR2
+9 KILL ZR,ZR1,ZR2
SKIP SET PSXT="DISP"
End DoDot:1
+1 if PSXTST=2
SET PSXT="RTRN"
+2 if PSXTST=3
SET PSXT="NDISP"
+3 QUIT
T1 XECUTE ^DD("DD")
QUIT
Z1 FOR C=1:1:79
WRITE "="
+1 KILL C
+2 QUIT
