- PSORXVW2 ;ISC-BIRM/PDW - view cmop activity logs ; 4/13/12 2:54pm
- ;;7.0;OUTPATIENT PHARMACY;**33,71,117,152,148,367,361,655,720**;DEC 1997;Build 1
- ; 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
- 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),PSXA)_" "_$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'="") D
- . . 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
- . ; FDA Medication Guide
- . N FDAMGDOC S FDAMGDOC=$G(^PSRX(DA,4,PSXA,"FDA"))
- . I FDAMGDOC'="" D
- . . S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="FDA Med Guide: "_$E(FDAMGDOC,1,61)
- . . I $L(FDAMGDOC)>61 D
- . . . F Q:$E(FDAMGDOC,62,999)="" D
- . . . . S FDAMGDOC=$E(FDAMGDOC,62,999),IEN=IEN+1
- . . . . S ^TMP("PSOAL",$J,IEN,0)=$E(FDAMGDOC,1,61)
- 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
- .I PSXFIL,$D(^PSRX(DA,"RTS",0)),$$REFRTS(DA,PSXFIL) 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
- 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)="X":"EXCEPT",1:"")
- Q
- ;
- DATE(RX,RFL,PSXA) ;
- N ZDT,ZD1,ZD2,PSXSDT S PSXSDT=0 ; ;p655 For dispensed status return shipping date
- I $G(PSXTST)=1 D
- . S ZDT=$P($G(^PSRX(RX,4,PSXA,1)),"^",2) K PSXA
- . S ZD1=$P(ZDT,"."),ZD1=$E(ZD1,4,5)_"/"_$E(ZD1,6,7)_"/"_$E(ZD1,2,3)
- . S ZD2=$E($P(ZDT,".",2),1,4)
- . S PSXSDT=ZD1_"@"_ZD2
- I +PSXSDT Q PSXSDT ;--p655 end
- ;
- I $G(PSXTST)=3,$G(PSXTCAN)'="" Q PSXTCAN
- ;original code: 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
- REFRTS(PSORXN,PSOFN) ; p720 (Rx#,Fill Number) Return 1 if refill is returned to stock and label is created after RTS
- N PSXA,PSFILL,RTS,LBLDT,LBLFLN
- F PSXA=0:0 S PSXA=$O(^PSRX(PSORXN,"RTS",PSXA)) Q:'PSXA D
- . S PSFILL=$P($G(^PSRX(PSORXN,"RTS",1,0)),"^",2) Q:PSFILL'=PSOFN
- . S RTS(PSFILL)=$P($G(^PSRX(PSORXN,"RTS",1,0)),"^") ; rts date
- Q:'$D(RTS(PSOFN)) 0
- F PSXA=0:0 S PSXA=$O(^PSRX(PSORXN,"L",PSXA)) Q:'PSXA D
- . S LBLFLN=$P($G(^PSRX(PSORXN,"L",PSXA,0)),"^",2) ; label fill number
- . Q:LBLFLN'=PSOFN
- . S LBLDT=$P($G(^PSRX(PSORXN,"L",PSXA,0)),"^") ; label date/time
- Q:$G(LBLDT)>(RTS(PSOFN)) 1
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXVW2 8216 printed Apr 23, 2025@18:49:10 Page 2
- PSORXVW2 ;ISC-BIRM/PDW - view cmop activity logs ; 4/13/12 2:54pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**33,71,117,152,148,367,361,655,720**;DEC 1997;Build 1
- +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 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)=" "
- +9 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)="CMOP Event Log:"
- SET IEN=IEN+1
- +10 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)="="
- +11 FOR PSXA=0:0
- SET PSXA=$ORDER(^PSRX(DA,4,PSXA))
- if 'PSXA
- QUIT
- SET PSX4=^(PSXA,0)
- DO FIX
- Begin DoDot:1
- +12 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)=$$DATE(DA,$PIECE(PSX4,"^",3),PSXA)_" "_$SELECT('PSXFIL:"Orig",1:"Ref "_$GET(PSXFIL))_" "_$GET(PSXBREF)
- +13 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:"")
- +14 IF PSXCAR'=""!(PSXID'="")
- Begin DoDot:2
- +15 NEW X
- SET X="Carrier: "_$EXTRACT(PSXCAR,1,21)
- +16 SET X=$$SETSTR^VALM1("Pkg ID: ",X,32,8)
- +17 SET X=X_PSXID
- +18 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)=X
- End DoDot:2
- +19 ; FDA Medication Guide
- +20 NEW FDAMGDOC
- SET FDAMGDOC=$GET(^PSRX(DA,4,PSXA,"FDA"))
- +21 IF FDAMGDOC'=""
- Begin DoDot:2
- +22 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)="FDA Med Guide: "_$EXTRACT(FDAMGDOC,1,61)
- +23 IF $LENGTH(FDAMGDOC)>61
- Begin DoDot:3
- +24 FOR
- if $EXTRACT(FDAMGDOC,62,999)=""
- QUIT
- Begin DoDot:4
- +25 SET FDAMGDOC=$EXTRACT(FDAMGDOC,62,999)
- SET IEN=IEN+1
- +26 SET ^TMP("PSOAL",$JOB,IEN,0)=$EXTRACT(FDAMGDOC,1,61)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 if $ORDER(^PSRX(DA,5,0))
- Begin DoDot:1
- +28 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)=" "
- +29 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)="CMOP Lot#/Expiration Date Log:"
- SET IEN=IEN+1
- +30 SET ^TMP("PSOAL",$JOB,IEN,0)="Rx Ref Lot # Expiration Date"
- +31 SET IEN=IEN+1
- SET $PIECE(^TMP("PSOAL",$JOB,IEN,0),"=",79)="="
- +32 FOR PSXZ=0:0
- SET PSXZ=$ORDER(^PSRX(DA,5,PSXZ))
- if PSXZ']""
- QUIT
- SET PSXLOT=^(PSXZ,0)
- Begin DoDot:2
- +33 SET EXPDT=$PIECE(PSXLOT,U,2)
- +34 SET EXPDT=$EXTRACT(EXPDT,4,5)_"/"_$EXTRACT(EXPDT,6,7)_"/"_$EXTRACT(EXPDT,2,3)
- +35 SET RXREF=$PIECE(PSXLOT,U,3)
- +36 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 IF PSXFIL
- IF $DATA(^PSRX(DA,"RTS",0))
- IF $$REFRTS(DA,PSXFIL)
- SET PSXT="Disp Refill Deleted"
- QUIT
- +5 SET PSX1=$SELECT(PSXFIL=0:$PIECE(^PSRX(DA,2),"^",13),1:$PIECE(^PSRX(DA,1,PSXFIL,0),"^",18))
- +6 if PSX1']""
- QUIT
- +7 IF PSX1'["."
- SET PSXRDT=$EXTRACT(PSX1,4,5)_"/"_$EXTRACT(PSX1,6,7)_"/"_$EXTRACT(PSX1,2,3)
- GOTO SKIP
- +8 SET ZR=PSX1
- SET ZR1=$PIECE(ZR,".")
- SET ZR2=$PIECE(ZR,".",2)
- +9 SET ZR2=$EXTRACT(ZR2,1,4)
- +10 SET PSXRDT=$EXTRACT(ZR1,4,5)_"/"_$EXTRACT(ZR1,6,7)_"/"_$EXTRACT(ZR1,2,3)_"@"_ZR2
- +11 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 SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)=" "
- SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)="Copay Activity Log:"
- +2 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)="="
- +3 IF '$ORDER(^PSRX(DA,"COPAY",0))
- SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)="There's NO Copay activity to report"
- QUIT
- +4 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
- +5 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
- +6 IF REA
- Begin DoDot:2
- +7 SET STA=$PIECE("ANNUAL CAP REACHED^COPAY RESET^IB-INITIATED COPAY^REMOVE COPAY CHARGE^RX EDITED^","^",REA)
- +8 SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_STA_$EXTRACT(RN,$LENGTH(STA)+1,21)
- End DoDot:2
- +9 IF '$TEST
- SET $PIECE(STA," ",21)=" "
- SET ^TMP("PSOAL",$JOB,IEN,0)=^TMP("PSOAL",$JOB,IEN,0)_STA
- +10 KILL STA,RN
- SET $PIECE(RN," ",15)=" "
- SET RF=+$PIECE(P1,"^",4)
- +11 SET RFT=$SELECT(RF>0:"REFILL "_RF,1:"ORIGINAL")
- +12 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))
- +13 if $PIECE(P1,"^",5)]""!($PIECE(P1,"^",6)]"")!($PIECE(P1,"^",7)]"")
- SET IEN=IEN+1
- SET ^TMP("PSOAL",$JOB,IEN,0)="Comment: "_$PIECE(P1,"^",5)
- +14 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
- +15 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)="X":"EXCEPT",1:"")
- +11 QUIT
- +12 ;
- DATE(RX,RFL,PSXA) ;
- +1 ; ;p655 For dispensed status return shipping date
- NEW ZDT,ZD1,ZD2,PSXSDT
- SET PSXSDT=0
- +2 IF $GET(PSXTST)=1
- Begin DoDot:1
- +3 SET ZDT=$PIECE($GET(^PSRX(RX,4,PSXA,1)),"^",2)
- KILL PSXA
- +4 SET ZD1=$PIECE(ZDT,".")
- SET ZD1=$EXTRACT(ZD1,4,5)_"/"_$EXTRACT(ZD1,6,7)_"/"_$EXTRACT(ZD1,2,3)
- +5 SET ZD2=$EXTRACT($PIECE(ZDT,".",2),1,4)
- +6 SET PSXSDT=ZD1_"@"_ZD2
- End DoDot:1
- +7 ;--p655 end
- IF +PSXSDT
- QUIT PSXSDT
- +8 ;
- +9 IF $GET(PSXTST)=3
- IF $GET(PSXTCAN)'=""
- QUIT PSXTCAN
- +10 ;original code: I $G(PSXTST)=1 Q $G(PSXRDT)
- +11 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)
- +12 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)
- +13 QUIT $GET(PSXTRDT)
- +14 ;
- 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
- REFRTS(PSORXN,PSOFN) ; p720 (Rx#,Fill Number) Return 1 if refill is returned to stock and label is created after RTS
- +1 NEW PSXA,PSFILL,RTS,LBLDT,LBLFLN
- +2 FOR PSXA=0:0
- SET PSXA=$ORDER(^PSRX(PSORXN,"RTS",PSXA))
- if 'PSXA
- QUIT
- Begin DoDot:1
- +3 SET PSFILL=$PIECE($GET(^PSRX(PSORXN,"RTS",1,0)),"^",2)
- if PSFILL'=PSOFN
- QUIT
- +4 ; rts date
- SET RTS(PSFILL)=$PIECE($GET(^PSRX(PSORXN,"RTS",1,0)),"^")
- End DoDot:1
- +5 if '$DATA(RTS(PSOFN))
- QUIT 0
- +6 FOR PSXA=0:0
- SET PSXA=$ORDER(^PSRX(PSORXN,"L",PSXA))
- if 'PSXA
- QUIT
- Begin DoDot:1
- +7 ; label fill number
- SET LBLFLN=$PIECE($GET(^PSRX(PSORXN,"L",PSXA,0)),"^",2)
- +8 if LBLFLN'=PSOFN
- QUIT
- +9 ; label date/time
- SET LBLDT=$PIECE($GET(^PSRX(PSORXN,"L",PSXA,0)),"^")
- End DoDot:1
- +10 if $GET(LBLDT)>(RTS(PSOFN))
- QUIT 1
- +11 QUIT 0
