PSORXVW2 ;ISC-BIRM/PDW - view cmop activity logs ;29-May-2012 15:14;PLS
;;7.0;OUTPATIENT PHARMACY;**33,71,117,152,1005,148,1015**;DEC 1997;Build 62
; External Referrence to file # 550.2 granted by DBIA 2231
;External reference to ^PS(50.607 supported by DBIA 2221
;External reference to ^PS(51.2 supported by DBIA 2226
;External reference to File ^PS(55 supported by DBIA 2228
;External reference to VA(200 supported by DBIA 10060
;get data from event multiple
; Modified - IHS/CIA/PLS - 01/09/04 - Line COPAY+1
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" "
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="CMOP Event Log:",IEN=IEN+1
S ^TMP("PSOAL",$J,IEN,0)="Date/Time Rx Ref TRN-Order Stat Comments",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
F PSXA=0:0 S PSXA=$O(^PSRX(DA,4,PSXA)) Q:'PSXA S PSX4=^(PSXA,0) D FIX D
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$$DATE(DA,$P(PSX4,"^",3))_" "_$S('PSXFIL:"Orig",1:"Ref "_$G(PSXFIL))_" "_$G(PSXBREF)
.S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" "_$G(PSXT)_" "_$S($G(PSXTST)=3:$E($P($G(PSXCAN),"^"),1,35),$G(PSXNDC)'="":"NDC: "_PSXNDC,1:"")
. I PSXCAR="",PSXID="" Q
. N X S X="Carrier: "_$E(PSXCAR,1,21)
. S X=$$SETSTR^VALM1("Pkg ID: ",X,32,8)
. S X=X_PSXID
. S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=X
D:$O(^PSRX(DA,5,0))
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" "
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="CMOP Lot#/Expiration Date Log:",IEN=IEN+1
.S ^TMP("PSOAL",$J,IEN,0)="Rx Ref Lot # Expiration Date"
.S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
.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)
..S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$S(RXREF=0:"Orig",RXREF>0:"Ref "_RXREF,1:"")_" "_$P(PSXLOT,U)_" "_EXPDT
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
K PSXCAR,PSXID
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))
S PSXCAR=$P(PSXCAN,U,3)
S PSXID=$P(PSXCAN,U,4)
; get cmop site
S I1=PSXBAT ; 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"
S PSXRDT="Not Released"
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
;
COPAY ;Copay activity log
Q:$G(DUZ("AG"))="I" ; IHS/CIA/PLS - 01/09/04 - Copay not used in IHS
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Copay Activity Log:"
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="# Date Reason Rx Ref Initiator Of Activity",IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0),"=",79)="="
I '$O(^PSRX(DA,"COPAY",0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="There's NO Copay activity to report" Q
F N=0:0 S N=$O(^PSRX(DA,"COPAY",N)) Q:'N S P1=^(N,0),DTT=P1\1 D DAT^PSORXVW1 D
.S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=N_" "_DAT_" ",$P(RN," ",21)=" ",REA=$P(P1,"^",2),REA=$F("ARICE",REA)-1
.I REA D
..S STA=$P("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA)
..S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA_$E(RN,$L(STA)+1,21)
.E S $P(STA," ",21)=" ",^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_STA
.K STA,RN S $P(RN," ",15)=" ",RF=+$P(P1,"^",4)
.S RFT=$S(RF>0:"REFILL "_RF,1:"ORIGINAL")
.S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_RFT_$E(RN,$L(RFT)+1,15)_$S($D(^VA(200,+$P(P1,"^",3),0)):$P(^(0),"^"),1:$P(P1,"^",3))
.S:$P(P1,"^",5)]""!($P(P1,"^",6)]"")!($P(P1,"^",7)]"") IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comment: "_$P(P1,"^",5)
.I $P(P1,"^",6)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_" Old value="_$P(P1,"^",6)_" New value="_$P(P1,"^",7)
Q
DOSE ;displays dosing instruction for both simple and complex Rxs.
I '$O(^PSRX(DA,6,0)) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Dosage: " Q
F I=0:0 S I=$O(^PSRX(DA,6,I)) Q:'I S DOSE=^PSRX(DA,6,I,0) D DOSE1
K DOSE
Q
DOSE1 ;
I '$P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Verb: "_$P(DOSE,"^",9)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" *Dosage: "_$S($E($P(DOSE,"^"),1)="."&($P(DOSE,"^",2)):"0",1:"")_$P(DOSE,"^")_$S($P(DOSE,"^",3):$P(^PS(50.607,$P(DOSE,"^",3),0),"^"),1:"")
I '$P(DOSE,"^",2),$P($G(^PS(55,PSODFN,"LAN")),"^") S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Oth. Lang. Dosage: "_$G(^PSRX(DA,6,I,1))
I $P(DOSE,"^",2),$P(DOSE,"^",9)]"" S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Verb: "_$P(DOSE,"^",9)
I $P(DOSE,"^",2) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Dispense Units: "_$S($E($P(DOSE,"^",2),1)=".":"0",1:"")_$P(DOSE,"^",2)
I $P(DOSE,"^",2) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" Noun: "_$P(DOSE,"^",4)
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" *Route: "_$S($P(DOSE,"^",7):$P(^PS(51.2,$P(DOSE,"^",7),0),"^"),1:"")
S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" *Schedule: "_$P(DOSE,"^",8)
I $P(DOSE,"^",5)]"" S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" *Duration: "_$P(DOSE,"^",5)_" ("_$S($P(DOSE,"^",5)["M":"MINUTES",$P(DOSE,"^",5)["H":"HOURS",$P(DOSE,"^",5)["L":"MONTHS",$P(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")"
I $P(DOSE,"^",6)]"" S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" *Conjunction: "_$S($P(DOSE,"^",6)="A":"AND",$P(DOSE,"^",6)="T":"THEN",$P(DOSE,"^",6)="E":"EXCEPT",1:"")
Q
;
DATE(RX,RFL) ;
I $G(PSXTST)=3,$G(PSXTCAN)'="" Q PSXTCAN
I $G(PSXTST)=1 Q $G(PSXRDT)
I $G(PSXTST)=3,'RFL,$$GET1^DIQ(52,RX,32.1,"I") Q $$FMTE^XLFDT($$GET1^DIQ(52,RX,32.1,"I"),2)
I $G(PSXTST)=3,RFL,$$GET1^DIQ(52.1,RFL_","_RX,5,"I") Q $$FMTE^XLFDT($$GET1^DIQ(52.1,RFL_","_RX,32.1,"I"),2)
Q $G(PSXTRDT)
;
DAT S DAT="",DTT=DTT\1 Q:DTT'?7N S DAT=$E(DTT,4,5)_"/"_$E(DTT,6,7)_"/"_$E(DTT,2,3)
Q
PSORXVW2 ;ISC-BIRM/PDW - view cmop activity logs ;29-May-2012 15:14;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**33,71,117,152,1005,148,1015**;DEC 1997;Build 62
+2 ; External Referrence to file # 550.2 granted by DBIA 2231
+3 ;External reference to ^PS(50.607 supported by DBIA 2221
+4 ;External reference to ^PS(51.2 supported by DBIA 2226
+5 ;External reference to File ^PS(55 supported by DBIA 2228
+6 ;External reference to VA(200 supported by DBIA 10060
+7 ;get data from event multiple
+8 ; Modified - IHS/CIA/PLS - 01/09/04 - Line COPAY+1
+9 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "
+10 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="CMOP Event Log:"
SET IEN=IEN+1
+11 SET ^TMP("PSOAL",$JOB,IEN,0)="Date/Time Rx Ref TRN-Order Stat Comments"
SET IEN=IEN+1
SET $PIECE(^TMP("PSOAL",$JOB,IEN,0),"=",79)="="
+12 FOR PSXA=0:0
SET PSXA=$ORDER(^PSRX(DA,4,PSXA))
IF 'PSXA
QUIT
SET PSX4=^(PSXA,0)
DO FIX
Begin DoDot:1
+13 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$$DATE(DA,$PIECE(PSX4,"^",3))_" "_$SELECT('PSXFIL:"Orig",1:"Ref "_$GET(PSXFIL))_" "_$GET(PSXBREF)
+14 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" "_$GET(PSXT)_" "_$SELECT($GET(PSXTST)=3:$EXTRACT($PIECE($GET(PSXCAN),"^"),1,35),$GET(PSXNDC)'="":"NDC: "_PSXNDC,1:"")
+15 IF PSXCAR=""
IF PSXID=""
QUIT
+16 NEW X
SET X="Carrier: "_$EXTRACT(PSXCAR,1,21)
+17 SET X=$$SETSTR^VALM1("Pkg ID: ",X,32,8)
+18 SET X=X_PSXID
+19 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=X
End DoDot:1
+20 IF $ORDER(^PSRX(DA,5,0))
Begin DoDot:1
+21 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "
+22 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="CMOP Lot#/Expiration Date Log:"
SET IEN=IEN+1
+23 SET ^TMP("PSOAL",$JOB,IEN,0)="Rx Ref Lot # Expiration Date"
+24 SET IEN=IEN+1
SET $PIECE(^TMP("PSOAL",$JOB,IEN,0),"=",79)="="
+25 FOR PSXZ=0:0
SET PSXZ=$ORDER(^PSRX(DA,5,PSXZ))
IF PSXZ']""
QUIT
SET PSXLOT=^(PSXZ,0)
Begin DoDot:2
+26 SET EXPDT=$PIECE(PSXLOT,U,2)
+27 SET EXPDT=$EXTRACT(EXPDT,4,5)_"/"_$EXTRACT(EXPDT,6,7)_"/"_$EXTRACT(EXPDT,2,3)
+28 SET RXREF=$PIECE(PSXLOT,U,3)
+29 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=$SELECT(RXREF=0:"Orig",RXREF>0:"Ref "_RXREF,1:"")_" "_$PIECE(PSXLOT,U)_" "_EXPDT
End DoDot:2
End DoDot:1
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 KILL PSXCAR,PSXID
+5 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 SET PSXCAR=$PIECE(PSXCAN,U,3)
+3 SET PSXID=$PIECE(PSXCAN,U,4)
+4 ; get cmop site
+5 ; S I1=$O(^PSX(550.2,"B",PSXBAT,""))
SET I1=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 SET PSXRDT="Not Released"
+2 IF PSXTST=1
Begin DoDot:1
+3 IF PSXFIL>0
IF ('$DATA(^PSRX(DA,1,PSXFIL,0)))
SET PSXT="Disp Refill Deleted"
QUIT
+4 SET PSX1=$SELECT(PSXFIL=0:$PIECE(^PSRX(DA,2),"^",13),1:$PIECE(^PSRX(DA,1,PSXFIL,0),"^",18))
+5 IF PSX1']""
QUIT
+6 IF PSX1'["."
SET PSXRDT=$EXTRACT(PSX1,4,5)_"/"_$EXTRACT(PSX1,6,7)_"/"_$EXTRACT(PSX1,2,3)
GOTO SKIP
+7 SET ZR=PSX1
SET ZR1=$PIECE(ZR,".")
SET ZR2=$PIECE(ZR,".",2)
+8 SET ZR2=$EXTRACT(ZR2,1,4)
+9 SET PSXRDT=$EXTRACT(ZR1,4,5)_"/"_$EXTRACT(ZR1,6,7)_"/"_$EXTRACT(ZR1,2,3)_"@"_ZR2
+10 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
+4 ;
COPAY ;Copay activity log
+1 ; IHS/CIA/PLS - 01/09/04 - Copay not used in IHS
IF $GET(DUZ("AG"))="I"
QUIT
+2 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" "
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="Copay Activity Log:"
+3 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="# Date Reason Rx Ref Initiator Of Activity"
SET IEN=IEN+1
SET $PIECE(^TMP("PSOAL",$JOB,IEN,0),"=",79)="="
+4 IF '$ORDER(^PSRX(DA,"COPAY",0))
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="There's NO Copay activity to report"
QUIT
+5 FOR N=0:0
SET N=$ORDER(^PSRX(DA,"COPAY",N))
IF 'N
QUIT
SET P1=^(N,0)
SET DTT=P1\1
DO DAT^PSORXVW1
Begin DoDot:1
+6 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=N_" "_DAT_" "
SET $PIECE(RN," ",21)=" "
SET REA=$PIECE(P1,"^",2)
SET REA=$FIND("ARICE",REA)-1
+7 IF REA
Begin DoDot:2
+8 SET STA=$PIECE("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA)
+9 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_STA_$EXTRACT(RN,$LENGTH(STA)+1,21)
End DoDot:2
+10 IF '$TEST
SET $PIECE(STA," ",21)=" "
SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_STA
+11 KILL STA,RN
SET $PIECE(RN," ",15)=" "
SET RF=+$PIECE(P1,"^",4)
+12 SET RFT=$SELECT(RF>0:"REFILL "_RF,1:"ORIGINAL")
+13 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_RFT_$EXTRACT(RN,$LENGTH(RFT)+1,15)_$SELECT($DATA(^VA(200,+$PIECE(P1,"^",3),0)):$PIECE(^(0),"^"),1:$PIECE(P1,"^",3))
+14 IF $PIECE(P1,"^",5)]""!($PIECE(P1,"^",6)]"")!($PIECE(P1,"^",7)]"")
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)="Comment: "_$PIECE(P1,"^",5)
+15 IF $PIECE(P1,"^",6)]""
SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_" Old value="_$PIECE(P1,"^",6)_" New value="_$PIECE(P1,"^",7)
End DoDot:1
+16 QUIT
DOSE ;displays dosing instruction for both simple and complex Rxs.
+1 IF '$ORDER(^PSRX(DA,6,0))
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Dosage: "
QUIT
+2 FOR I=0:0
SET I=$ORDER(^PSRX(DA,6,I))
IF 'I
QUIT
SET DOSE=^PSRX(DA,6,I,0)
DO DOSE1
+3 KILL DOSE
+4 QUIT
DOSE1 ;
+1 IF '$PIECE(DOSE,"^",2)
IF $PIECE(DOSE,"^",9)]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Verb: "_$PIECE(DOSE,"^",9)
+2 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" *Dosage: "_$SELECT($EXTRACT($PIECE(DOSE,"^"),1)="."&($PIECE(DOSE,"^",2)):"0",1:"")_$PIECE(DOSE,"^")_$SELECT($PIECE(DOSE,"^",3):$PIECE(^PS(50.607,$PIECE(DOSE,"^",3),0),"^"),1:"")
+3 IF '$PIECE(DOSE,"^",2)
IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Oth. Lang. Dosage: "_$GET(^PSRX(DA,6,I,1))
+4 IF $PIECE(DOSE,"^",2)
IF $PIECE(DOSE,"^",9)]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Verb: "_$PIECE(DOSE,"^",9)
+5 IF $PIECE(DOSE,"^",2)
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Dispense Units: "_$SELECT($EXTRACT($PIECE(DOSE,"^",2),1)=".":"0",1:"")_$PIECE(DOSE,"^",2)
+6 IF $PIECE(DOSE,"^",2)
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" Noun: "_$PIECE(DOSE,"^",4)
+7 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" *Route: "_$SELECT($PIECE(DOSE,"^",7):$PIECE(^PS(51.2,$PIECE(DOSE,"^",7),0),"^"),1:"")
+8 SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" *Schedule: "_$PIECE(DOSE,"^",8)
+9 IF $PIECE(DOSE,"^",5)]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" *Duration: "_$PIECE(DOSE,"^",5)_" ("_$SELECT($PIECE(DOSE,"^",5)["M":"MINUTES",$PIECE(DOSE,"^",5)["H":"HOURS",$PIECE(DOSE,"^",5)["L":"MONTHS",$PIECE(DOSE,"^",5)["W":"WEEKS",1:"DAYS")_")"
+10 IF $PIECE(DOSE,"^",6)]""
SET IEN=IEN+1
SET ^TMP("PSOAL",$JOB,IEN,0)=" *Conjunction: "_$SELECT($PIECE(DOSE,"^",6)="A":"AND",$PIECE(DOSE,"^",6)="T":"THEN",$PIECE(DOSE,"^",6)="E":"EXCEPT",1:"")
+11 QUIT
+12 ;
DATE(RX,RFL) ;
+1 IF $GET(PSXTST)=3
IF $GET(PSXTCAN)'=""
QUIT PSXTCAN
+2 IF $GET(PSXTST)=1
QUIT $GET(PSXRDT)
+3 IF $GET(PSXTST)=3
IF 'RFL
IF $$GET1^DIQ(52,RX,32.1,"I")
QUIT $$FMTE^XLFDT($$GET1^DIQ(52,RX,32.1,"I"),2)
+4 IF $GET(PSXTST)=3
IF RFL
IF $$GET1^DIQ(52.1,RFL_","_RX,5,"I")
QUIT $$FMTE^XLFDT($$GET1^DIQ(52.1,RFL_","_RX,32.1,"I"),2)
+5 QUIT $GET(PSXTRDT)
+6 ;
DAT SET DAT=""
SET DTT=DTT\1
IF DTT'?7N
QUIT
SET DAT=$EXTRACT(DTT,4,5)_"/"_$EXTRACT(DTT,6,7)_"/"_$EXTRACT(DTT,2,3)
+1 QUIT
