- PSORXL1 ;BIR/SAB - action to be taken on prescriptions ; June 09, 2023@11:10:21
- ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274,287,289,358,251,385,403,409,482,604,562,441,717,712**;DEC 1997;Build 20
- ;
- ; Reference to $$DS^PSSDSAPI in ICR #5424
- ;
- S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
- S1 F PI=1:1 Q:$P(PPL,",",PI)="" S DA=$P(PPL,",",PI) D
- .S PSORFD1=0 F PSOX7=0:0 S PSOX7=$O(^PSRX(DA,1,PSOX7)) Q:'$G(PSOX7) S (PSORFD1)=PSOX7
- .I 'PSORFD1,$$DS^PSSDSAPI,($G(^PS(52.4,DA,1))>0)&('$D(^XUSEC("PSORPH",DUZ))) S SPPL=SPPL_DA_"," Q
- .I 'PSORFD1,$P(^PSRX(DA,"STA"),"^")=4!($D(^PSRX(DA,"DRI"))&('$D(^XUSEC("PSORPH",DUZ)))) S SPPL=SPPL_DA_"," Q
- .I $P(^PSRX(DA,"STA"),"^")<10,$P(^("STA"),"^")'=4 D SUS Q
- .K PSORFD1,PSOX7
- I $G(SPPL)]"" D K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DUOUT,DTOUT,DIRUT
- .W !!,$C(7),"Drug Interaction Rx(s) and/or Dose Warning: " F I=1:1 Q:$P(SPPL,",",I)="" W $P(^PSRX($P(SPPL,",",I),0),"^")_", "
- .I $G(PSOLAP)=""!($G(PSOLAP)=$G(ION)) W !,"Label device must be selected for Drug Interaction or dose warning label!"
- .S PPL=SPPL,DG=1 N PPL1 D Q^PSORXL K DG,SPPL
- S SUSPT="SUSPENSE" G D1
- Q
- SUS ;
- ;PSO*7.0*604 New variable RX0
- N RX0
- S ACT=1,RXN=DA,RX0=^PSRX(DA,0),SD=$S($G(ZD(DA)):$E(ZD(DA),1,7),1:$P(^(3),"^")),RXS=$O(^PS(52.5,"B",DA,0)) I RXS S RXCMOP=$P($G(^PS(52.5,RXS,0)),"^",7) D Q:$G(DFLG)!($G(PSOWFLG))
- .;checks to see if future fill exists
- .S PSOWFLG=0 I '$G(RXPR(DA)),$P($G(^PS(52.5,RXS,"P")),"^")=0,$P($G(^PSRX(DA,"STA")),"^")=5 D SWARN Q:$G(PSOWFLG)
- .K PSOWFLG I $G(RXPR(DA)),'$P($G(^PS(52.5,RXS,"P")),"^") D WARN Q:$G(DFLG)
- .S DA=RXS,DIK="^PS(52.5," D ^DIK S DA=RXN I $P($G(^PSRX(RXN,"STA")),"^")=5 S $P(^("STA"),"^")=0
- G:$G(RXRP(DA))!($G(RXPR(DA))) LOCK
- I $G(PSXSYS) D SUS1^PSOCMOP I $G(XFLAG)=1 K XFLAG Q
- LOCK I $P($G(^PSRX(RXN,"STA")),"^")=3 G SUSQ
- ; The PSOSITE variable will not be set by the code that processes the CMOP release message - PSO*7*403
- I '$G(PSOSITE) N PSOSITE S PSOSITE=$$RXSITE^PSOBPSUT(RXN,$G(RXFL(RXN)))
- S RXP=+$G(RXPR(DA)),DIC="^PS(52.5,",DIC(0)="L",X=RXN,DIC("DR")=".02///"_SD_";.03////"_$P(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0" K DD,DO D FILE^DICN D I +Y,'$G(RXP),$G(RXRP(RXN)) S $P(^PS(52.5,+Y,0),"^",12)=1
- .K DD,DO I +Y,$G(PSOEXREP) S $P(^PS(52.5,+Y,0),"^",12)=1
- .I +Y S $P(^PS(52.5,+Y,0),"^",13)=$G(RXFL(RXN))
- S $P(^PSRX(RXN,"STA"),"^")=5,LFD=$E(SD,4,5)_"-"_$E(SD,6,7)_"-"_$E(SD,2,3) D ACT
- W !!,$S(RXP:"Partial ",1:"")_"RX# ",$P(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"."
- S VALMSG=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
- S COMM=$S(RXP:"Partial ",1:"")_"Rx# "_$P(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$S($G(RXRP(RXN))&('$G(RXP)):" (Reprint)",1:"")
- D:'$D(^TMP("PSORXN",$J,RXN)) EN^PSOHLSN1(RXN,"SC","ZS",COMM)
- S:$D(^TMP("PSORXN",$J,RXN)) $P(^TMP("PSORXN",$J,RXN),"^",4)=COMM
- ;
- ; - If not a PARTIAL, reverse ECME Claim, if necessary
- I '$G(RXFL(RXN)) S RXFL(RXN)=$$LSTRFL^PSOBPSU1(RXN)
- I '$G(RXP),'$G(PSONPROG) D REVERSE^PSOBPSU1(RXN,,"DC",3) ;PSONPROG - TRICARE or CHAMPVA in progress, don't reverse
- K COMM
- ;
- ;Telephone refill does not use list manager
- K:$G(VEXPSORX)!($G(VEXANS2)]"") VALMSG ;PSO*7*409
- ;
- SUSQ Q
- ;PSO*7*274 always recalculate RXF
- ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I S RXF=I S:I>5 RXF=I+1
- S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA S IR=FDA
- S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- D NOW^%DTC S ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$S(RXP:"Partial ",1:"")_"RX "_$S($G(RXRP(DA))&('$G(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD K RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
- Q
- D1 I $O(PSORX("PSOL",$G(PPL1))) S PPL1=$O(PSORX("PSOL",$G(PPL1))),PPL=PSORX("PSOL",PPL1) G S1
- G:$D(RXRS) RXS^PSORXL
- K LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG
- Q
- WARN W ! K DIR,DIRUT,DUOUT,DTOUT,DFLG S Y=$P(^PS(52.5,RXS,0),"^",2) X ^DD("DD") S RXPD=Y,DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT"
- S DIR("A",1)="Rx #"_$P(^PSRX(DA,0),"^")_" is suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD
- I $G(RXCMOP)]"" D G WARN1
- .W !!,"A partial entered for this Rx cannot be suspended."
- .W !,"You may pull this fill from suspense or print the label now.",!!
- .S DIR("A",2)=" ",DIR("A",3)=" Do you want to Queue to print",DIR("A")=" or Exit: "
- S DIR("A",2)=" ",DIR("A",3)=" Do you want to: Suspend Partial",DIR("A",4)=" Queue to print",DIR("A")=" or Exit: "
- WARN1 S DIR("B")="EXIT",DIR("?")="^D HLP^PSORXL1" D ^DIR K DIR
- I Y="E"!($D(DIRUT))!(Y="S"&($G(RXCMOP)]"")) S DA(1)=DA,DA=RXPR(DA),DIK="^PSRX("_DA(1)_",""P""," D ^DIK S ^PSRX(DA(1),"TYPE")=0,DFLG=1 W $C(7)," Partial Removed!" Q
- I Y="Q" S DPPL=PPL,HOLDPPL1=$G(PPL1),DPI=PI,RXLTOP=1 S PPL=$G(RXN)_"," S PSPARTXX=1 D Q^PSORXL K PSPARTXX S DFLG=1,PPL=DPPL,PI=DPI,PPL1=$G(HOLDPPL1) K HOLDPPL1,DPPL,DPPI,DPI,RXLTOP Q
- Q
- HLP I $G(RXCMOP)']"" W !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",!
- I $G(RXCMOP)]"" W !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense."
- W !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",!
- W !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered."
- Q
- SWARN ;
- S PSORXLDA=$G(DA),PSORXZD=$P($G(^PS(52.5,RXS,0)),"^",2)
- W $C(7),!!,"Rx "_$P($G(^PSRX(DA,0)),"^")_" is already suspended "_$S($G(RXCMOP)]"":"for CMOP ",1:"")_"until "_$E(PSORXZD,4,5)_"-"_$E(PSORXZD,6,7)_"-"_$E(PSORXZD,2,3)_"." K PSORXZD
- W !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",!
- N PSORF,PSOTRIC D TRIC(DA)
- I PSOTRIC,$$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE" S PSOQFLAG=1 Q
- K DIR S DIR(0)="SA^Q:QUEUE;S:SUSPEND",DIR("B")="Q",DIR("A")="Do you want to Queue to print or Suspend Rx "_$P($G(^PSRX(DA,0)),"^")_": " D ^DIR K DIR
- I $G(Y)="S" K RXFL(PSORXLDA) G SWARNQ
- I $G(Y)="Q" D G SWARNQ
- . S PSOKSPPL=$G(PPL),PSOZXPPL=$G(PPL1),PSOZXPI=$G(PI),RXLTOP=1
- . S PPL=$G(RXN)_"," D SWARS D Q^PSORXL S PSOWFLG=1,PPL=PSOKSPPL
- . S PI=PSOZXPI,PPL1=PSOZXPPL K PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$G(PSORXLDA))
- W !!,"Nothing queued to print for Rx "_$P($G(^PSRX(PSORXLDA,0)),"^"),! S PSOWFLG=1
- SWARNQ ;
- S DA=$G(PSORXLDA) K PSORXLDA
- Q
- SWARS ;
- S PSOZXFL(PSORXLDA)=+$P($G(^PS(52.5,+$G(RXS),0)),"^",13) I '$G(PSOZXFL(PSORXLDA)) K PSOZXFL Q
- S PSOZXFPL=$P(PSOKSPPL,",",+$G(PI),99)
- S PSOZXFPN=$L(PSOZXFPL,PPL)-1
- I $G(PSOZXFL(PSORXLDA)),$G(PSOZXFPN) S RXFL(PSORXLDA)=$G(PSOZXFL(PSORXLDA))-$G(PSOZXFPN)
- K PSOZXFL,PSOZXFPL,PSOZXFPN
- Q
- TRIC(PSORX) ;
- S PSORF=$$LSTRFL^PSOBPSU1(PSORX)
- S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(PSORX,PSORF,.PSOTRIC)
- Q
- ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED
- N PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP,PSOSTA,PSOTRIC,ESTAT
- S PPLTMP=$G(PPL)
- F PSOI=1:1 S PSORX=+$P($G(PPLTMP),",",PSOI) Q:'PSORX D
- . D TRIC(PSORX) S ESTAT=$P($$STATUS^PSOBPSUT(PSORX,PSORF),"^")
- . I $G(PSOCKDC) D Q ;PSOCKDC variable is set in PSORXL and is used to eliminate label print for DC'ed Rx's
- . . S PSOSTA=$$GET1^DIQ(52,PSORX,100,"I")
- . . I PSOSTA=12!(PSOSTA=11)!(PSOSTA=3)!((PSOSTA=5)&(ESTAT'="")) D ;p717 Add HOLD status
- . . . I '$G(RXPR(PSORX)),'$G(RXRS(PSORX)),$G(PPL) D RMV(PSORX,.PPL) ;p604 added RXRS array check
- . I $G(RXPR(PSORX)) Q
- . S PSOACT="",BWH=$S(PSORF:"RF",1:"OF")
- . I $$FIND^PSOREJUT(PSORX,PSORF) D I PSOACT="Q" D RMV(PSORX,.PPL) Q
- . . S PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88,943",BWH,"OIQ","Q")
- Q
- RMV(RX,PPL) ; Remove the Rx from the label print queue
- N XPPL,I
- S XPPL=PPL,PPL="" F I=1:1:$L(XPPL,",") I $P(XPPL,",",I)'="",$P(XPPL,",",I)'=RX S PPL=PPL_$P(XPPL,",",I)_","
- I PPL="" K PPL
- Q
- ;
- PPLPARK ;CHECK IF RX IN PPL STRING IS PARKED - REMOVE IT IF IT IS SO LABEL DOES NOT PRINT
- ;ROUTINE PSORXL WAS TOO LARGE SO ADDED TAG HERE
- N PSOPX,PSOPRX
- F PSOPX=1:1 S PSOPRX=$P($G(PPL),",",PSOPX) Q:PSOPRX="" I '$D(^PSRX(PSOPRX,"PARK")) S PSOPX(PSOPRX)=""
- S PPL="",PSOPX=0 I $D(PSOPX)>1 F S PSOPX=$O(PSOPX(PSOPX)) Q:'PSOPX S PPL=PPL_PSOPX_","
- K PSOPX S PSOPRX=0 F S PSOPRX=$O(RXRS(PSOPRX)) Q:'PSOPRX I '$D(^PSRX(PSOPRX,"PARK")) S PSOPX(PSOPRX)=RXRS(PSOPRX)
- K RXRS S PSOPX=0 F S PSOPX=$O(PSOPX(PSOPX)) Q:'PSOPX S RXRS(PSOPX)=PSOPX(PSOPX)
- K PSOPX F PSOPX=1:1 S PSOPRX=$P($G(PSORX("PSOL",1)),",",PSOPX) Q:PSOPRX="" I '$D(^PSRX(PSOPRX,"PARK")) S PSOPX(PSOPRX)=""
- S PSORX("PSOL",1)="",PSOPX=0 I $D(PSOPX)>1 F S PSOPX=$O(PSOPX(PSOPX)) Q:'PSOPX S PSORX("PSOL",1)=PSORX("PSOL",1)_PSOPX_","
- Q
- ;
- PK ;
- K SPPL S SPPL="" F PI=1:1 Q:$P(PPL,",",PI)="" D ;*712
- .N PSOPARK,PSODRUG,ZZ
- .S PSOPARK=1
- .S DA=$P(PPL,",",PI) D I PSOPARK D PRK^PSOPRK(DA) W:$G(^PSRX(DA,"PARK")) !,ZZ," placed in Active/Parked status." Q
- ..S PSODRUG=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^"),ZZ="RX# "_$P(^PSRX(DA,0),"^")_" "_PSODRUG
- ..I $P(^PSRX(DA,"STA"),"^")'=0,($P(^("STA"),"^")'=5) W !,ZZ," not active or suspended!" S PSOPARK=0 Q
- ..S PSODRUG("DEA")=$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^",3)
- ..I $G(PSODRUG("DEA"))["D"!(PSODRUG["CLOZAPINE") W !,ZZ," - drug not allowed to be parked!" S PSOPARK=0
- .I $P(^PSRX(DA,"STA"),"^")=4 S SPPL=SPPL_DA_"," Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXL1 9692 printed Feb 19, 2025@00:00:58 Page 2
- PSORXL1 ;BIR/SAB - action to be taken on prescriptions ; June 09, 2023@11:10:21
- +1 ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274,287,289,358,251,385,403,409,482,604,562,441,717,712**;DEC 1997;Build 20
- +2 ;
- +3 ; Reference to $$DS^PSSDSAPI in ICR #5424
- +4 ;
- S SET SPPL=""
- SET PPL1=1
- if '$GET(PPL)
- SET PPL=$GET(PSORX("PSOL",PPL1))
- if $GET(PPL)']""
- GOTO D1
- S1 FOR PI=1:1
- if $PIECE(PPL,",",PI)=""
- QUIT
- SET DA=$PIECE(PPL,",",PI)
- Begin DoDot:1
- +1 SET PSORFD1=0
- FOR PSOX7=0:0
- SET PSOX7=$ORDER(^PSRX(DA,1,PSOX7))
- if '$GET(PSOX7)
- QUIT
- SET (PSORFD1)=PSOX7
- +2 IF 'PSORFD1
- IF $$DS^PSSDSAPI
- IF ($GET(^PS(52.4,DA,1))>0)&('$DATA(^XUSEC("PSORPH",DUZ)))
- SET SPPL=SPPL_DA_","
- QUIT
- +3 IF 'PSORFD1
- IF $PIECE(^PSRX(DA,"STA"),"^")=4!($DATA(^PSRX(DA,"DRI"))&('$DATA(^XUSEC("PSORPH",DUZ))))
- SET SPPL=SPPL_DA_","
- QUIT
- +4 IF $PIECE(^PSRX(DA,"STA"),"^")<10
- IF $PIECE(^("STA"),"^")'=4
- DO SUS
- QUIT
- +5 KILL PSORFD1,PSOX7
- End DoDot:1
- +6 IF $GET(SPPL)]""
- Begin DoDot:1
- +7 WRITE !!,$CHAR(7),"Drug Interaction Rx(s) and/or Dose Warning: "
- FOR I=1:1
- if $PIECE(SPPL,",",I)=""
- QUIT
- WRITE $PIECE(^PSRX($PIECE(SPPL,",",I),0),"^")_", "
- +8 IF $GET(PSOLAP)=""!($GET(PSOLAP)=$GET(ION))
- WRITE !,"Label device must be selected for Drug Interaction or dose warning label!"
- +9 SET PPL=SPPL
- SET DG=1
- NEW PPL1
- DO Q^PSORXL
- KILL DG,SPPL
- End DoDot:1
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR,DUOUT,DTOUT,DIRUT
- +10 SET SUSPT="SUSPENSE"
- GOTO D1
- +11 QUIT
- SUS ;
- +1 ;PSO*7.0*604 New variable RX0
- +2 NEW RX0
- +3 SET ACT=1
- SET RXN=DA
- SET RX0=^PSRX(DA,0)
- SET SD=$SELECT($GET(ZD(DA)):$EXTRACT(ZD(DA),1,7),1:$PIECE(^(3),"^"))
- SET RXS=$ORDER(^PS(52.5,"B",DA,0))
- IF RXS
- SET RXCMOP=$PIECE($GET(^PS(52.5,RXS,0)),"^",7)
- Begin DoDot:1
- +4 ;checks to see if future fill exists
- +5 SET PSOWFLG=0
- IF '$GET(RXPR(DA))
- IF $PIECE($GET(^PS(52.5,RXS,"P")),"^")=0
- IF $PIECE($GET(^PSRX(DA,"STA")),"^")=5
- DO SWARN
- if $GET(PSOWFLG)
- QUIT
- +6 KILL PSOWFLG
- IF $GET(RXPR(DA))
- IF '$PIECE($GET(^PS(52.5,RXS,"P")),"^")
- DO WARN
- if $GET(DFLG)
- QUIT
- +7 SET DA=RXS
- SET DIK="^PS(52.5,"
- DO ^DIK
- SET DA=RXN
- IF $PIECE($GET(^PSRX(RXN,"STA")),"^")=5
- SET $PIECE(^("STA"),"^")=0
- End DoDot:1
- if $GET(DFLG)!($GET(PSOWFLG))
- QUIT
- +8 if $GET(RXRP(DA))!($GET(RXPR(DA)))
- GOTO LOCK
- +9 IF $GET(PSXSYS)
- DO SUS1^PSOCMOP
- IF $GET(XFLAG)=1
- KILL XFLAG
- QUIT
- LOCK IF $PIECE($GET(^PSRX(RXN,"STA")),"^")=3
- GOTO SUSQ
- +1 ; The PSOSITE variable will not be set by the code that processes the CMOP release message - PSO*7*403
- +2 IF '$GET(PSOSITE)
- NEW PSOSITE
- SET PSOSITE=$$RXSITE^PSOBPSUT(RXN,$GET(RXFL(RXN)))
- +3 SET RXP=+$GET(RXPR(DA))
- SET DIC="^PS(52.5,"
- SET DIC(0)="L"
- SET X=RXN
- SET DIC("DR")=".02///"_SD_";.03////"_$PIECE(^PSRX(DA,0),"^",2)_";.04///M;.05///"_RXP_";.06////"_PSOSITE_";2///0"
- KILL DD,DO
- DO FILE^DICN
- Begin DoDot:1
- +4 KILL DD,DO
- IF +Y
- IF $GET(PSOEXREP)
- SET $PIECE(^PS(52.5,+Y,0),"^",12)=1
- +5 IF +Y
- SET $PIECE(^PS(52.5,+Y,0),"^",13)=$GET(RXFL(RXN))
- End DoDot:1
- IF +Y
- IF '$GET(RXP)
- IF $GET(RXRP(RXN))
- SET $PIECE(^PS(52.5,+Y,0),"^",12)=1
- +6 SET $PIECE(^PSRX(RXN,"STA"),"^")=5
- SET LFD=$EXTRACT(SD,4,5)_"-"_$EXTRACT(SD,6,7)_"-"_$EXTRACT(SD,2,3)
- DO ACT
- +7 WRITE !!,$SELECT(RXP:"Partial ",1:"")_"RX# ",$PIECE(^PSRX(RXN,0),"^")_" has been suspended until "_LFD_"."
- +8 SET VALMSG=$SELECT(RXP:"Partial ",1:"")_"Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$SELECT($GET(RXRP(RXN))&('$GET(RXP)):" (Reprint)",1:"")
- +9 SET COMM=$SELECT(RXP:"Partial ",1:"")_"Rx# "_$PIECE(^PSRX(RXN,0),"^")_" Has Been Suspended Until "_LFD_"."_$SELECT($GET(RXRP(RXN))&('$GET(RXP)):" (Reprint)",1:"")
- +10 if '$DATA(^TMP("PSORXN",$JOB,RXN))
- DO EN^PSOHLSN1(RXN,"SC","ZS",COMM)
- +11 if $DATA(^TMP("PSORXN",$JOB,RXN))
- SET $PIECE(^TMP("PSORXN",$JOB,RXN),"^",4)=COMM
- +12 ;
- +13 ; - If not a PARTIAL, reverse ECME Claim, if necessary
- +14 IF '$GET(RXFL(RXN))
- SET RXFL(RXN)=$$LSTRFL^PSOBPSU1(RXN)
- +15 ;PSONPROG - TRICARE or CHAMPVA in progress, don't reverse
- IF '$GET(RXP)
- IF '$GET(PSONPROG)
- DO REVERSE^PSOBPSU1(RXN,,"DC",3)
- +16 KILL COMM
- +17 ;
- +18 ;Telephone refill does not use list manager
- +19 ;PSO*7*409
- if $GET(VEXPSORX)!($GET(VEXANS2)]"")
- KILL VALMSG
- +20 ;
- SUSQ QUIT
- +1 ;PSO*7*274 always recalculate RXF
- ACT SET RXF=0
- FOR I=0:0
- SET I=$ORDER(^PSRX(DA,1,I))
- if 'I
- QUIT
- SET RXF=I
- if I>5
- SET RXF=I+1
- +1 SET IR=0
- FOR FDA=0:0
- SET FDA=$ORDER(^PSRX(DA,"A",FDA))
- if 'FDA
- QUIT
- SET IR=FDA
- +2 SET IR=IR+1
- SET ^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- +3 DO NOW^%DTC
- SET ^PSRX(DA,"A",IR,0)=%_"^S^"_DUZ_"^"_RXF_"^"_$SELECT(RXP:"Partial ",1:"")_"RX "_$SELECT($GET(RXRP(DA))&('$GET(RXP)):"Reprint ",1:"")_"Placed on Suspense until "_LFD
- KILL RXF,I,FDA,DIC,DIE,DR,Y,X,%,%H,%I
- +4 QUIT
- D1 IF $ORDER(PSORX("PSOL",$GET(PPL1)))
- SET PPL1=$ORDER(PSORX("PSOL",$GET(PPL1)))
- SET PPL=PSORX("PSOL",PPL1)
- GOTO S1
- +1 if $DATA(RXRS)
- GOTO RXS^PSORXL
- +2 KILL LBL,PPL1,PPL,DIR,%DT,%,SD,COUNT,EXDT,L,PDUZ,REF,REPRINT,RFDATE,RFL1,RFLL,RXN,WARN,ZY,FLD,PI,ZD,ACT,X,Y,DIRUT,DUOUT,DTOUT,DIROUT,DFLG,RXPD,PSOWFLG
- +3 QUIT
- WARN WRITE !
- KILL DIR,DIRUT,DUOUT,DTOUT,DFLG
- SET Y=$PIECE(^PS(52.5,RXS,0),"^",2)
- XECUTE ^DD("DD")
- SET RXPD=Y
- SET DIR(0)="SA^S:SUSPEND;Q:QUEUE;E:EXIT"
- +1 SET DIR("A",1)="Rx #"_$PIECE(^PSRX(DA,0),"^")_" is suspended "_$SELECT($GET(RXCMOP)]"":"for CMOP ",1:"")_"until "_RXPD
- +2 IF $GET(RXCMOP)]""
- Begin DoDot:1
- +3 WRITE !!,"A partial entered for this Rx cannot be suspended."
- +4 WRITE !,"You may pull this fill from suspense or print the label now.",!!
- +5 SET DIR("A",2)=" "
- SET DIR("A",3)=" Do you want to Queue to print"
- SET DIR("A")=" or Exit: "
- End DoDot:1
- GOTO WARN1
- +6 SET DIR("A",2)=" "
- SET DIR("A",3)=" Do you want to: Suspend Partial"
- SET DIR("A",4)=" Queue to print"
- SET DIR("A")=" or Exit: "
- WARN1 SET DIR("B")="EXIT"
- SET DIR("?")="^D HLP^PSORXL1"
- DO ^DIR
- KILL DIR
- +1 IF Y="E"!($DATA(DIRUT))!(Y="S"&($GET(RXCMOP)]""))
- SET DA(1)=DA
- SET DA=RXPR(DA)
- SET DIK="^PSRX("_DA(1)_",""P"","
- DO ^DIK
- SET ^PSRX(DA(1),"TYPE")=0
- SET DFLG=1
- WRITE $CHAR(7)," Partial Removed!"
- QUIT
- +2 IF Y="Q"
- SET DPPL=PPL
- SET HOLDPPL1=$GET(PPL1)
- SET DPI=PI
- SET RXLTOP=1
- SET PPL=$GET(RXN)_","
- SET PSPARTXX=1
- DO Q^PSORXL
- KILL PSPARTXX
- SET DFLG=1
- SET PPL=DPPL
- SET PI=DPI
- SET PPL1=$GET(HOLDPPL1)
- KILL HOLDPPL1,DPPL,DPPI,DPI,RXLTOP
- QUIT
- +3 QUIT
- HLP IF $GET(RXCMOP)']""
- WRITE !!,"If you choose to suspend this partial Rx, the current suspended fill will",!,"be replaced by the partial. You may want to pull this fill early instead.",!
- +1 IF $GET(RXCMOP)]""
- WRITE !!,"You cannot suspend a partial when a CMOP fill is in suspense, because the partial will replace the CMOP fill in suspense."
- +2 WRITE !,"If you choose to queue this partial, the label will printout on the previous",!,"selected label printer.",!
- +3 WRITE !,"You may exit without printing or suspending this partial. This will also delete",!,"the partial Rx entered."
- +4 QUIT
- SWARN ;
- +1 SET PSORXLDA=$GET(DA)
- SET PSORXZD=$PIECE($GET(^PS(52.5,RXS,0)),"^",2)
- +2 WRITE $CHAR(7),!!,"Rx "_$PIECE($GET(^PSRX(DA,0)),"^")_" is already suspended "_$SELECT($GET(RXCMOP)]"":"for CMOP ",1:"")_"until "_$EXTRACT(PSORXZD,4,5)_"-"_$EXTRACT(PSORXZD,6,7)_"-"_$EXTRACT(PSORXZD,2,3)_"."
- KILL PSORXZD
- +3 WRITE !,"By suspending this fill, the fill that is already suspended will be overwritten",!,"and a label will not print for that fill!",!
- +4 NEW PSORF,PSOTRIC
- DO TRIC(DA)
- +5 IF PSOTRIC
- IF $$STATUS^PSOBPSUT(DA,PSORF)'["PAYABLE"
- SET PSOQFLAG=1
- QUIT
- +6 KILL DIR
- SET DIR(0)="SA^Q:QUEUE;S:SUSPEND"
- SET DIR("B")="Q"
- SET DIR("A")="Do you want to Queue to print or Suspend Rx "_$PIECE($GET(^PSRX(DA,0)),"^")_": "
- DO ^DIR
- KILL DIR
- +7 IF $GET(Y)="S"
- KILL RXFL(PSORXLDA)
- GOTO SWARNQ
- +8 IF $GET(Y)="Q"
- Begin DoDot:1
- +9 SET PSOKSPPL=$GET(PPL)
- SET PSOZXPPL=$GET(PPL1)
- SET PSOZXPI=$GET(PI)
- SET RXLTOP=1
- +10 SET PPL=$GET(RXN)_","
- DO SWARS
- DO Q^PSORXL
- SET PSOWFLG=1
- SET PPL=PSOKSPPL
- +11 SET PI=PSOZXPI
- SET PPL1=PSOZXPPL
- KILL PSOKSPPL,PSOZXPPL,PSOZXPI,RXLTOP,RXFL(+$GET(PSORXLDA))
- End DoDot:1
- GOTO SWARNQ
- +12 WRITE !!,"Nothing queued to print for Rx "_$PIECE($GET(^PSRX(PSORXLDA,0)),"^"),!
- SET PSOWFLG=1
- SWARNQ ;
- +1 SET DA=$GET(PSORXLDA)
- KILL PSORXLDA
- +2 QUIT
- SWARS ;
- +1 SET PSOZXFL(PSORXLDA)=+$PIECE($GET(^PS(52.5,+$GET(RXS),0)),"^",13)
- IF '$GET(PSOZXFL(PSORXLDA))
- KILL PSOZXFL
- QUIT
- +2 SET PSOZXFPL=$PIECE(PSOKSPPL,",",+$GET(PI),99)
- +3 SET PSOZXFPN=$LENGTH(PSOZXFPL,PPL)-1
- +4 IF $GET(PSOZXFL(PSORXLDA))
- IF $GET(PSOZXFPN)
- SET RXFL(PSORXLDA)=$GET(PSOZXFL(PSORXLDA))-$GET(PSOZXFPN)
- +5 KILL PSOZXFL,PSOZXFPL,PSOZXFPN
- +6 QUIT
- TRIC(PSORX) ;
- +1 SET PSORF=$$LSTRFL^PSOBPSU1(PSORX)
- +2 SET PSOTRIC=""
- SET PSOTRIC=$$TRIC^PSOREJP1(PSORX,PSORF,.PSOTRIC)
- +3 QUIT
- ECME ; - Looks for DUR/79 REJECTS and send Mail Rx's to ECME that have not been SUSPENDED
- +1 NEW PSOI,PSOJ,PSORX,PSORF,PSOACT,BWH,PPLTMP,PSOSTA,PSOTRIC,ESTAT
- +2 SET PPLTMP=$GET(PPL)
- +3 FOR PSOI=1:1
- SET PSORX=+$PIECE($GET(PPLTMP),",",PSOI)
- if 'PSORX
- QUIT
- Begin DoDot:1
- +4 DO TRIC(PSORX)
- SET ESTAT=$PIECE($$STATUS^PSOBPSUT(PSORX,PSORF),"^")
- +5 ;PSOCKDC variable is set in PSORXL and is used to eliminate label print for DC'ed Rx's
- IF $GET(PSOCKDC)
- Begin DoDot:2
- +6 SET PSOSTA=$$GET1^DIQ(52,PSORX,100,"I")
- +7 ;p717 Add HOLD status
- IF PSOSTA=12!(PSOSTA=11)!(PSOSTA=3)!((PSOSTA=5)&(ESTAT'=""))
- Begin DoDot:3
- +8 ;p604 added RXRS array check
- IF '$GET(RXPR(PSORX))
- IF '$GET(RXRS(PSORX))
- IF $GET(PPL)
- DO RMV(PSORX,.PPL)
- End DoDot:3
- End DoDot:2
- QUIT
- +9 IF $GET(RXPR(PSORX))
- QUIT
- +10 SET PSOACT=""
- SET BWH=$SELECT(PSORF:"RF",1:"OF")
- +11 IF $$FIND^PSOREJUT(PSORX,PSORF)
- Begin DoDot:2
- +12 SET PSOACT=$$HDLG^PSOREJU1(PSORX,PSORF,"79,88,943",BWH,"OIQ","Q")
- End DoDot:2
- IF PSOACT="Q"
- DO RMV(PSORX,.PPL)
- QUIT
- End DoDot:1
- +13 QUIT
- RMV(RX,PPL) ; Remove the Rx from the label print queue
- +1 NEW XPPL,I
- +2 SET XPPL=PPL
- SET PPL=""
- FOR I=1:1:$LENGTH(XPPL,",")
- IF $PIECE(XPPL,",",I)'=""
- IF $PIECE(XPPL,",",I)'=RX
- SET PPL=PPL_$PIECE(XPPL,",",I)_","
- +3 IF PPL=""
- KILL PPL
- +4 QUIT
- +5 ;
- PPLPARK ;CHECK IF RX IN PPL STRING IS PARKED - REMOVE IT IF IT IS SO LABEL DOES NOT PRINT
- +1 ;ROUTINE PSORXL WAS TOO LARGE SO ADDED TAG HERE
- +2 NEW PSOPX,PSOPRX
- +3 FOR PSOPX=1:1
- SET PSOPRX=$PIECE($GET(PPL),",",PSOPX)
- if PSOPRX=""
- QUIT
- IF '$DATA(^PSRX(PSOPRX,"PARK"))
- SET PSOPX(PSOPRX)=""
- +4 SET PPL=""
- SET PSOPX=0
- IF $DATA(PSOPX)>1
- FOR
- SET PSOPX=$ORDER(PSOPX(PSOPX))
- if 'PSOPX
- QUIT
- SET PPL=PPL_PSOPX_","
- +5 KILL PSOPX
- SET PSOPRX=0
- FOR
- SET PSOPRX=$ORDER(RXRS(PSOPRX))
- if 'PSOPRX
- QUIT
- IF '$DATA(^PSRX(PSOPRX,"PARK"))
- SET PSOPX(PSOPRX)=RXRS(PSOPRX)
- +6 KILL RXRS
- SET PSOPX=0
- FOR
- SET PSOPX=$ORDER(PSOPX(PSOPX))
- if 'PSOPX
- QUIT
- SET RXRS(PSOPX)=PSOPX(PSOPX)
- +7 KILL PSOPX
- FOR PSOPX=1:1
- SET PSOPRX=$PIECE($GET(PSORX("PSOL",1)),",",PSOPX)
- if PSOPRX=""
- QUIT
- IF '$DATA(^PSRX(PSOPRX,"PARK"))
- SET PSOPX(PSOPRX)=""
- +8 SET PSORX("PSOL",1)=""
- SET PSOPX=0
- IF $DATA(PSOPX)>1
- FOR
- SET PSOPX=$ORDER(PSOPX(PSOPX))
- if 'PSOPX
- QUIT
- SET PSORX("PSOL",1)=PSORX("PSOL",1)_PSOPX_","
- +9 QUIT
- +10 ;
- PK ;
- +1 ;*712
- KILL SPPL
- SET SPPL=""
- FOR PI=1:1
- if $PIECE(PPL,",",PI)=""
- QUIT
- Begin DoDot:1
- +2 NEW PSOPARK,PSODRUG,ZZ
- +3 SET PSOPARK=1
- +4 SET DA=$PIECE(PPL,",",PI)
- Begin DoDot:2
- +5 SET PSODRUG=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^")
- SET ZZ="RX# "_$PIECE(^PSRX(DA,0),"^")_" "_PSODRUG
- +6 IF $PIECE(^PSRX(DA,"STA"),"^")'=0
- IF ($PIECE(^("STA"),"^")'=5)
- WRITE !,ZZ," not active or suspended!"
- SET PSOPARK=0
- QUIT
- +7 SET PSODRUG("DEA")=$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^",3)
- +8 IF $GET(PSODRUG("DEA"))["D"!(PSODRUG["CLOZAPINE")
- WRITE !,ZZ," - drug not allowed to be parked!"
- SET PSOPARK=0
- End DoDot:2
- IF PSOPARK
- DO PRK^PSOPRK(DA)
- if $GET(^PSRX(DA,"PARK"))
- WRITE !,ZZ," placed in Active/Parked status."
- QUIT
- +9 IF $PIECE(^PSRX(DA,"STA"),"^")=4
- SET SPPL=SPPL_DA_","
- QUIT
- End DoDot:1
- +10 QUIT