- 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 Feb 18, 2025@23:11:49 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