- PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;Jan 20, 2022@11:21:55
- ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281,287,289,358,385,403,427,496,544,562,441**;DEC 1997;Build 208
- ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- SEL I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
- N PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
- K DIR,DUOUT,DTOUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!('Y) S VALMSG="Nothing pulled from suspense!",VALMBCK="" Q
- S PSLST=Y
- SELQ D FULL^VALM1
- K DIR S DIR("A")="Select routing for Rx(s)",DIR(0)="S^M:MAIL;W:WINDOW",DIR("B")="WINDOW" D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
- S PSOSQRTE=Y I $G(PSOSQRTE)="W",$P(PSOPAR,"^",12) K DIR S DIR(0)="FO^2:60",DIR("A")="METHOD OF PICK-UP" D ^DIR S PSOSQMTH=$G(Y) K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) G END
- W ! K DIR S DIR(0)="Y",DIR("A")="Pull Rx(s) and delete from suspense",DIR("B")="YES" D D ^DIR K DIR I Y'=1 G END
- .S DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from",DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
- .S DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option.",DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
- Q:$G(PULLONE)
- F SORD=1:1:$L(PSLST,",") Q:$P(PSLST,",",SORD)']"" S SORN=$P(PSLST,",",SORD) D:+PSOLST(SORN)=52 BEG
- S VALMBCK="R"
- I '$G(PSOSQ) S VALMSG="No Rx's pulled from suspense!"
- Q
- BEG ;
- S RXREC=$P(PSOLST(SORN),"^",2)
- BEGQ Q:'$D(^PSRX(+$G(RXREC),0))
- D PSOL^PSSLOCK(RXREC) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P($G(^PSRX(RXREC,0)),"^")),! K PSOMSG D DIR Q
- K PSOMSG I $P($G(^PSRX(RXREC,"STA")),"^")'=5 W !!,"Rx# ",$P(^PSRX(RXREC,0),"^")," is not on Suspense",$S($G(^PSRX(RXREC,"PARK")):" and needs to be UNPARKED to be filled",1:""),"!" D DIR,ULRX Q ;p441 mwa added unparked message
- S SFN=$O(^PS(52.5,"B",RXREC,0)) I 'SFN D DIR,ULRX Q
- S PDUZ=DUZ I +$G(^PS(52.5,SFN,"P")) W !,">>> Rx #",$P(^PSRX(+$P(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL." D DIR,ULRX Q
- I +$P($G(^PSRX(RXREC,2)),"^",6)<DT,+$P($G(^("STA")),"^")<11 D S DIE=52,DA=RXREC,DR="100///11" D ^DIE S DA=SFN,DIK="^PS(52.5," D ^DIK K DIE,DA,DIK W !,"Rx # "_$P(^PSRX(RXREC,0),"^")_" has expired!" D DIR,ULRX Q
- .N PSCOU,AAA,VVV,QQQ,PSOPRT,PSOEXPI D EX^PSOSUTL
- I $D(RXRP(RXREC)) W !!,"A reprint has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
- I $D(RXPR(RXREC)) W !!,"A partial has already been requested for Rx # ",$P($G(^PSRX(RXREC,0)),"^") D DIR,ULRX Q
- S PSPOP=0 I $G(PSODIV),$P($G(^PS(52.5,SFN,0)),"^",6)'=$G(PSOSITE) D CKDIV I $G(PSPOP) D DIR,ULRX Q
- ;
- ; PSO*427-Check if Label Log indicates a label was already printed.
- N PRNTED,RFL
- S RFL=$P($G(^PS(52.5,SFN,0)),"^",13)
- S PRNTED=$$PRINTED^PSOSULBL(SFN,RXREC,RFL)
- ; PSO*427-If previously printed, ask user whether to continue. If NO (0), remove from suspense. If NO (0) or exit (-1), unlock and quit
- I PRNTED N CONT S CONT=$$PRTQUES^PSOSUPRX(RXREC,RFL) I CONT'=1 D Q
- . I CONT=0 D REMOVE^PSOSULBL(SFN,RXREC,RFL,DUZ,1,PRNTED)
- . I CONT=-1 W !,"This prescription will not be pulled but will be left on suspense."
- . D DIR,ULRX
- ;
- ; Submitting Rx to ECME for 3rd Party Billing and checking the outcome
- ; If there are unresolved DUR, Refill Too Soon, or TRICARE/CHAMPVA rejects, we will not add the RX to the
- ; list of RXs that are pulled from suspense
- ; We also need to quit if the user discontinued from the reject notification screen as the RX Suspense record
- ; is deleted by a discontinue
- ;
- ; Do not send a claim if the last submission was rejected and
- ; all rejects have been closed.
- ;
- N ACTION S ACTION=""
- N RFL S RFL=$G(RXFL(RXREC)) I RFL="" S RFL=$$LSTRFL^PSOBPSU1(RXREC)
- I '$D(RXPR(RXREC)),$$SEND^PSOBPSU2(RXREC,RFL) D I ACTION="Q"!(ACTION="D") D ULRX Q
- . D ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
- . ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
- . I $$PSOET^PSOREJP3(RXREC,RFL) S ACTION="Q" W !!,"Pull early cannot be done for non-billable TRICARE/CHAMPVA Rx on the worklist" D DIR Q
- . ; Check for unresolved rejects
- . I $$FIND^PSOREJUT(RXREC,RFL) S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PP","IOQ","Q")
- . ; Check for TRICARE/CHAMPVA that are not complete
- . I $$TRIC^PSOREJP1(RXREC,RFL),$P($$STATUS^PSOBPSUT(RXREC,RFL),U)="IN PROGRESS" S ACTION="Q" W !!,"Pull early cannot be done for IN PROGRESS TRICARE/CHAMPVA Rx" D DIR Q
- ;
- S:$P(^PS(52.5,SFN,0),"^",5) RXPR(RXREC)=$P(^(0),"^",5) S:$P(^PS(52.5,SFN,0),"^",12) RXRP(RXREC)=1
- S RXFL(RXREC)=$P($G(^PS(52.5,SFN,0)),"^",13),RXRS(RXREC)=$G(PSODFN),RXLTOP=1
- S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$S($P($G(^PS(52.5,SFN,0)),"^",4)="W":"W",1:"M")_"^"_$P($G(^PSRX(RXREC,"MP")),"^") S PSOGET="M" D GETMW
- S RXRS(RXREC)=$G(RXRS(RXREC))_"^"_$G(PSOGETF)_"^"_$G(PSOGETFN)_"^"_$S($G(PSOGET)="W":"W",1:"M")
- S $P(^PS(52.5,SFN,0),"^",4)=$G(PSOSQRTE) S MW=$G(PSOSQRTE) N RR,RFCNT D MAILS^PSOSUPAT I $D(PSOSQMTH) S $P(^PSRX(RXREC,"MP"),"^")=$G(PSOSQMTH)
- S PSOSQ=1
- ;
- D ULRX K PSOGET,PSOGETF
- Q
- WIND ;
- N RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
- S PBINGRTE=0,PSINTRX=RXREC
- I $G(RXPR(RXREC)) S RTETEST=$P($G(^PSRX(RXREC,"P",RXPR(PSINTRX),0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
- S PSOPSO=0 F SSSS=0:0 S SSSS=$O(^PSRX(PSINTRX,1,SSSS)) Q:'SSSS S PSOPSO=SSSS
- I 'PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,0)),"^",11) S:RTETEST="W" PBINGRTE=1 Q
- I PSOPSO S RTETEST=$P($G(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2) S:RTETEST="W" PBINGRTE=1 Q
- Q
- DIR ;
- W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR Q
- END S VALMSG="Nothing pulled from suspense!",VALMBCK="R" S:$G(PULLONE)=1 PULLONE=2 Q
- ADD ;Add Rx to SPSORX array
- I $G(SPSORX("PSOL",1))']"" S SPSORX("PSOL",1)=RXREC_"," Q
- F PSOX1=0:0 S PSOX1=$O(SPSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(SPSORX("PSOL",PSOX2))+$L(RXREC)<220 S SPSORX("PSOL",PSOX2)=SPSORX("PSOL",PSOX2)_RXREC_"," Q
- S SPSORX("PSOL",PSOX2+1)=RXREC_","
- Q
- BBADD ;
- N PSOX1,PSOX2
- I $G(BBRX(1))']"" S BBRX(1)=RXREC_"," Q
- F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(BBRX(PSOX2))+$L(RXREC)<220 S BBRX(PSOX2)=BBRX(PSOX2)_RXREC_"," Q
- S BBRX(PSOX2+1)=RXREC_","
- Q
- PPLADD ;
- ; This function will move entries from the RXRS array (which has RXs that were pulled
- ; from supense via the PP action on the Medication profile) to the list of RXs that
- ; will get a label (PPL variable and possible PSORX array).
- ; Note that arrays RXRS and PSORX and variable PPL are pre-existing
- N SZZ,SPSOX1,SPSOX2,LSFN
- I $G(PPL)'="",$E(PPL,$L(PPL))'="," S PPL=PPL_","
- ;
- ; Loop through entries in the RXRS array and process
- S SZZ=0 F S SZZ=$O(RXRS(SZZ)) Q:'SZZ D
- .; If SZZ is already set in the PPL variable do not set it again
- .I $G(PPL)[SZZ Q
- .; Check if label already printed per the RX SUSPENSE file
- .S LSFN=$O(^PS(52.5,"B",SZZ,0))
- .Q:'$G(LSFN)
- .Q:$G(^PS(52.5,LSFN,"P"))
- .; The following function checks for ECME conditions where we do not want a label
- .; This is probably redundant as the RXRS array entry should not have been created if any of these
- .; conditions existed but things might have changed after the entry was created
- .I $$ECMECHK^PSOREJU3(SZZ) Q
- .; Add to list of RXs that should get a label
- .I $G(PPL)="" S PPL=SZZ_"," Q
- .I $L(PPL)+$L(SZZ)<220 S PPL=PPL_SZZ_"," Q
- .I $G(PSORX("PSOL",2))']"" S PSORX("PSOL",2)=SZZ_"," Q
- .F SPSOX1=1:0 S SPSOX1=$O(PSORX("PSOL",SPSOX1)) Q:'SPSOX1 S SPSOX2=SPSOX1
- .I $L(PSORX("PSOL",SPSOX2))+$L(SZZ)<220 S PSORX("PSOL",SPSOX2)=PSORX("PSOL",SPSOX2)_SZZ_"," Q
- .S PSORX("PSOL",SPSOX2+1)=SZZ_","
- Q
- CKDIV ;
- I '$P($G(PSOSYS),"^",2) W !!?10,"Rx # ",$P(^PSRX(RXREC,0),"^")," is not a valid choice (Different Division)" S PSPOP=1 Q
- I $P($G(PSOSYS),"^",3) W !!?10 K DIR S DIR("A")="Rx # "_$P(^PSRX(RXREC,0),"^")_" is from another division. OK to Pull",DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR I $G(DIRUT)!('Y) S PSPOP=1
- Q
- SELONE ;Pull one Rx through Listman
- I $G(PSOBEDT) W $C(7),$C(7) S VALMSG="Invalid Action at this time !",VALMBCK="" Q
- N ORD,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,PULLONE,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
- S PULLONE=1
- I +PSOLST(ORN)'=52 S VALMBCK="" Q
- I +PSOLST(ORN)=52,$P($G(^PSRX($P(PSOLST(ORN),"^",2),"STA")),"^")'=5 S VALMSG="Rx is not on Suspense"_$S($G(^PSRX($P(PSOLST(ORN),"^",2),"PARK")):" and needs to be UNPARKED",1:"")_"!",VALMBCK="" Q ;p441 mwa added unparked message
- I +PSOLST(ORN)=52,$D(RXRS($P(PSOLST(ORN),"^",2))) S VALMSG="Pull early has already been requested!",VALMBCK="" Q
- N EHOLDQ,ESIEN,ERXIEN S ERXIEN=$P(PSOLST(ORN),"^",2),ESIEN="",ESIEN=$O(^PS(52.5,"B",ERXIEN,ESIEN))
- I $G(ESIEN),$$GET1^DIQ(52.5,ESIEN,10)'="" D EHOLD Q:$G(EHOLDQ)
- K EHOLDQ,ESIEN,ERXIEN
- D SELQ I $G(PULLONE)=2 S VALMSG="Rx# "_$P($G(^PSRX($P(PSOLST(ORN),"^",2),0)),"^")_" not pulled from suspense!" Q
- I +PSOLST(ORN)=52 S RXREC=$P(PSOLST(ORN),"^",2)
- D BEGQ S VALMSG="Rx# "_$P($G(^PSRX(+$G(RXREC),0)),"^")_$S($G(PSOSQ):" pulled",1:" not pulled")_" from Suspense!"
- S VALMBCK="R"
- Q
- RESET ;
- N RSDA,RXMW,RXMP,RXSP,RXR,DA,RXPSRX,RXFILL,RXFILLN
- F RSDA=0:0 S RSDA=$O(RXRS(RSDA)) Q:'RSDA D
- .S RXSP=$O(^PS(52.5,"B",RSDA,0)) Q:'RXSP
- .Q:'$D(^PS(52.5,RXSP,0))
- .S RXMW=$S($P($G(RXRS(RSDA)),"^",2)="":"M",1:$P($G(RXRS(RSDA)),"^",2)),RXMP=$P($G(RXRS(RSDA)),"^",3),RXFILL=$P($G(RXRS(RSDA)),"^",4),RXFILLN=$P($G(RXRS(RSDA)),"^",5),RXPSRX=$S($P($G(RXRS(RSDA)),"^",6)="":"M",1:$P($G(RXRS(RSDA)),"^",6))
- .I RXMW'="" S $P(^PS(52.5,RXSP,0),"^",4)=RXMW D
- ..I RXFILL="P" D Q
- ...I $D(^PSRX(RSDA,"P",+$G(RXFILLN),0)) S $P(^PSRX(RSDA,"P",+$G(RXFILLN),0),"^",2)=$G(RXPSRX),$P(^PSRX(RSDA,"MP"),"^")=RXMP
- ..I RXFILL="R",$G(RXFILLN) S DA(1)=RSDA,DA=RXFILLN,DIE="^PSRX("_DA(1)_",1,",DR="2////"_RXPSRX D ^DIE K DIE
- ..I RXFILL="O" S DA=RSDA,DIE="^PSRX(",DR="11////"_RXPSRX D ^DIE K DIE
- ..S $P(^PSRX(RSDA,"MP"),"^")=RXMP
- Q
- GETMW ;
- N GETPAR,GETRX,GETCNT
- S PSOGETF="O",PSOGETFN=""
- S GETPAR=$P($G(^PS(52.5,SFN,0)),"^",5)
- I GETPAR S PSOGET=$P($G(^PSRX(RXREC,"P",GETPAR,0)),"^",2),PSOGETF="P",PSOGETFN=GETPAR Q
- I '$O(^PSRX(RXREC,1,0)) S PSOGET=$P($G(^PSRX(RXREC,0)),"^",11) Q
- S GETRX=0 F GETCNT=0:0 S GETCNT=$O(^PSRX(RXREC,1,GETCNT)) Q:'GETCNT S GETRX=GETCNT
- S PSOGET=$P($G(^PSRX(RXREC,1,+$G(GETRX),0)),"^",2),PSOGETF="R",PSOGETFN=+$G(GETRX)
- Q
- ULRX ;
- I '$G(RXREC) Q
- D PSOUL^PSSLOCK(RXREC)
- Q
- EHOLD ;
- Q:'$G(ERXIEN)
- Q:$$GET1^DIQ(52,ERXIEN,86)=""
- D FULL^VALM1
- W !,"This is an ePharmacy billable fill which is Suspended until "_$$GET1^DIQ(52.5,ESIEN,10)_", based"
- W !,"on the 3/4 Days rule.",!
- K DIR S EHOLDQ=0,DIR(0)="YA",DIR("A")="Do you wish to continue? "
- D ^DIR I $D(DIRUT)!('Y) S EHOLDQ=1 K DIR
- S VALMSG="No action taken.",VALMBCK="R"
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUPOE 11092 printed Jan 18, 2025@03:36:42 Page 2
- PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;Jan 20, 2022@11:21:55
- +1 ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281,287,289,358,385,403,427,496,544,562,441**;DEC 1997;Build 208
- +2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- SEL IF '$GET(PSOCNT)
- SET VALMSG="This patient has no Prescriptions!"
- SET VALMBCK=""
- QUIT
- +1 NEW PSOGETF,PSOGET,PSOGETFN,ORD,ORN,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
- +2 KILL DIR,DUOUT,DTOUT
- SET DIR("A")="Select Orders by number"
- SET DIR(0)="LO^1:"_PSOCNT
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))!('Y)
- SET VALMSG="Nothing pulled from suspense!"
- SET VALMBCK=""
- QUIT
- +3 SET PSLST=Y
- SELQ DO FULL^VALM1
- +1 KILL DIR
- SET DIR("A")="Select routing for Rx(s)"
- SET DIR(0)="S^M:MAIL;W:WINDOW"
- SET DIR("B")="WINDOW"
- DO ^DIR
- KILL DIR
- IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO END
- +2 SET PSOSQRTE=Y
- IF $GET(PSOSQRTE)="W"
- IF $PIECE(PSOPAR,"^",12)
- KILL DIR
- SET DIR(0)="FO^2:60"
- SET DIR("A")="METHOD OF PICK-UP"
- DO ^DIR
- SET PSOSQMTH=$GET(Y)
- KILL DIR
- IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO END
- +3 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Pull Rx(s) and delete from suspense"
- SET DIR("B")="YES"
- Begin DoDot:1
- +4 SET DIR("?",1)="Enter Yes to pull selected Rx(s) from suspense. Since(Rx(s) pulled early from"
- SET DIR("?",2)="suspense are not associated with a printed batch, these Rx(s) cannot be"
- +5 SET DIR("?",3)="reprinted from suspense using the 'Reprint batches from suspense' option."
- SET DIR("?")="Therefore, any Rx(s) pulled early from suspense will be deleted from suspense."
- End DoDot:1
- DO ^DIR
- KILL DIR
- IF Y'=1
- GOTO END
- +6 if $GET(PULLONE)
- QUIT
- +7 FOR SORD=1:1:$LENGTH(PSLST,",")
- if $PIECE(PSLST,",",SORD)']""
- QUIT
- SET SORN=$PIECE(PSLST,",",SORD)
- if +PSOLST(SORN)=52
- DO BEG
- +8 SET VALMBCK="R"
- +9 IF '$GET(PSOSQ)
- SET VALMSG="No Rx's pulled from suspense!"
- +10 QUIT
- BEG ;
- +1 SET RXREC=$PIECE(PSOLST(SORN),"^",2)
- BEGQ if '$DATA(^PSRX(+$GET(RXREC),0))
- QUIT
- +1 DO PSOL^PSSLOCK(RXREC)
- IF '$GET(PSOMSG)
- WRITE !!,$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE($GET(PSOMSG),"^",2),1:"Another person is editing Rx "_$PIECE($GET(^PSRX(RXREC,0)),"^")),!
- KILL PSOMSG
- DO DIR
- QUIT
- +2 ;p441 mwa added unparked message
- KILL PSOMSG
- IF $PIECE($GET(^PSRX(RXREC,"STA")),"^")'=5
- WRITE !!,"Rx# ",$PIECE(^PSRX(RXREC,0),"^")," is not on Suspense",$SELECT($GET(^PSRX(RXREC,"PARK")):" and needs to be UNPARKED to be filled",1:""),"!"
- DO DIR
- DO ULRX
- QUIT
- +3 SET SFN=$ORDER(^PS(52.5,"B",RXREC,0))
- IF 'SFN
- DO DIR
- DO ULRX
- QUIT
- +4 SET PDUZ=DUZ
- IF +$GET(^PS(52.5,SFN,"P"))
- WRITE !,">>> Rx #",$PIECE(^PSRX(+$PIECE(^(0),"^"),0),"^")," ALREADY PRINTED FROM SUSPENSE.",!,?5,"USE THE REPRINT OPTION TO REPRINT LABEL."
- DO DIR
- DO ULRX
- QUIT
- +5 IF +$PIECE($GET(^PSRX(RXREC,2)),"^",6)<DT
- IF +$PIECE($GET(^("STA")),"^")<11
- Begin DoDot:1
- +6 NEW PSCOU,AAA,VVV,QQQ,PSOPRT,PSOEXPI
- DO EX^PSOSUTL
- End DoDot:1
- SET DIE=52
- SET DA=RXREC
- SET DR="100///11"
- DO ^DIE
- SET DA=SFN
- SET DIK="^PS(52.5,"
- DO ^DIK
- KILL DIE,DA,DIK
- WRITE !,"Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" has expired!"
- DO DIR
- DO ULRX
- QUIT
- +7 IF $DATA(RXRP(RXREC))
- WRITE !!,"A reprint has already been requested for Rx # ",$PIECE($GET(^PSRX(RXREC,0)),"^")
- DO DIR
- DO ULRX
- QUIT
- +8 IF $DATA(RXPR(RXREC))
- WRITE !!,"A partial has already been requested for Rx # ",$PIECE($GET(^PSRX(RXREC,0)),"^")
- DO DIR
- DO ULRX
- QUIT
- +9 SET PSPOP=0
- IF $GET(PSODIV)
- IF $PIECE($GET(^PS(52.5,SFN,0)),"^",6)'=$GET(PSOSITE)
- DO CKDIV
- IF $GET(PSPOP)
- DO DIR
- DO ULRX
- QUIT
- +10 ;
- +11 ; PSO*427-Check if Label Log indicates a label was already printed.
- +12 NEW PRNTED,RFL
- +13 SET RFL=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
- +14 SET PRNTED=$$PRINTED^PSOSULBL(SFN,RXREC,RFL)
- +15 ; PSO*427-If previously printed, ask user whether to continue. If NO (0), remove from suspense. If NO (0) or exit (-1), unlock and quit
- +16 IF PRNTED
- NEW CONT
- SET CONT=$$PRTQUES^PSOSUPRX(RXREC,RFL)
- IF CONT'=1
- Begin DoDot:1
- +17 IF CONT=0
- DO REMOVE^PSOSULBL(SFN,RXREC,RFL,DUZ,1,PRNTED)
- +18 IF CONT=-1
- WRITE !,"This prescription will not be pulled but will be left on suspense."
- +19 DO DIR
- DO ULRX
- End DoDot:1
- QUIT
- +20 ;
- +21 ; Submitting Rx to ECME for 3rd Party Billing and checking the outcome
- +22 ; If there are unresolved DUR, Refill Too Soon, or TRICARE/CHAMPVA rejects, we will not add the RX to the
- +23 ; list of RXs that are pulled from suspense
- +24 ; We also need to quit if the user discontinued from the reject notification screen as the RX Suspense record
- +25 ; is deleted by a discontinue
- +26 ;
- +27 ; Do not send a claim if the last submission was rejected and
- +28 ; all rejects have been closed.
- +29 ;
- +30 NEW ACTION
- SET ACTION=""
- +31 NEW RFL
- SET RFL=$GET(RXFL(RXREC))
- IF RFL=""
- SET RFL=$$LSTRFL^PSOBPSU1(RXREC)
- +32 IF '$DATA(RXPR(RXREC))
- IF $$SEND^PSOBPSU2(RXREC,RFL)
- Begin DoDot:1
- +33 DO ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
- +34 ; Quit if there is an unresolved TRICARE/CHAMPVA non-billable reject code, PSO*7*358
- +35 IF $$PSOET^PSOREJP3(RXREC,RFL)
- SET ACTION="Q"
- WRITE !!,"Pull early cannot be done for non-billable TRICARE/CHAMPVA Rx on the worklist"
- DO DIR
- QUIT
- +36 ; Check for unresolved rejects
- +37 IF $$FIND^PSOREJUT(RXREC,RFL)
- SET ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88,943","PP","IOQ","Q")
- +38 ; Check for TRICARE/CHAMPVA that are not complete
- +39 IF $$TRIC^PSOREJP1(RXREC,RFL)
- IF $PIECE($$STATUS^PSOBPSUT(RXREC,RFL),U)="IN PROGRESS"
- SET ACTION="Q"
- WRITE !!,"Pull early cannot be done for IN PROGRESS TRICARE/CHAMPVA Rx"
- DO DIR
- QUIT
- End DoDot:1
- IF ACTION="Q"!(ACTION="D")
- DO ULRX
- QUIT
- +40 ;
- +41 if $PIECE(^PS(52.5,SFN,0),"^",5)
- SET RXPR(RXREC)=$PIECE(^(0),"^",5)
- if $PIECE(^PS(52.5,SFN,0),"^",12)
- SET RXRP(RXREC)=1
- +42 SET RXFL(RXREC)=$PIECE($GET(^PS(52.5,SFN,0)),"^",13)
- SET RXRS(RXREC)=$GET(PSODFN)
- SET RXLTOP=1
- +43 SET RXRS(RXREC)=$GET(RXRS(RXREC))_"^"_$SELECT($PIECE($GET(^PS(52.5,SFN,0)),"^",4)="W":"W",1:"M")_"^"_$PIECE($GET(^PSRX(RXREC,"MP")),"^")
- SET PSOGET="M"
- DO GETMW
- +44 SET RXRS(RXREC)=$GET(RXRS(RXREC))_"^"_$GET(PSOGETF)_"^"_$GET(PSOGETFN)_"^"_$SELECT($GET(PSOGET)="W":"W",1:"M")
- +45 SET $PIECE(^PS(52.5,SFN,0),"^",4)=$GET(PSOSQRTE)
- SET MW=$GET(PSOSQRTE)
- NEW RR,RFCNT
- DO MAILS^PSOSUPAT
- IF $DATA(PSOSQMTH)
- SET $PIECE(^PSRX(RXREC,"MP"),"^")=$GET(PSOSQMTH)
- +46 SET PSOSQ=1
- +47 ;
- +48 DO ULRX
- KILL PSOGET,PSOGETF
- +49 QUIT
- WIND ;
- +1 NEW RRT,RRTT,XXXX,JJJJ,PSINTRX,RTETEST,PSOPSO,SSSS
- +2 SET PBINGRTE=0
- SET PSINTRX=RXREC
- +3 IF $GET(RXPR(RXREC))
- SET RTETEST=$PIECE($GET(^PSRX(RXREC,"P",RXPR(PSINTRX),0)),"^",2)
- if RTETEST="W"
- SET PBINGRTE=1
- QUIT
- +4 SET PSOPSO=0
- FOR SSSS=0:0
- SET SSSS=$ORDER(^PSRX(PSINTRX,1,SSSS))
- if 'SSSS
- QUIT
- SET PSOPSO=SSSS
- +5 IF 'PSOPSO
- SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,0)),"^",11)
- if RTETEST="W"
- SET PBINGRTE=1
- QUIT
- +6 IF PSOPSO
- SET RTETEST=$PIECE($GET(^PSRX(PSINTRX,1,PSOPSO,0)),"^",2)
- if RTETEST="W"
- SET PBINGRTE=1
- QUIT
- +7 QUIT
- DIR ;
- +1 WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue"
- DO ^DIR
- KILL DIR
- QUIT
- END SET VALMSG="Nothing pulled from suspense!"
- SET VALMBCK="R"
- if $GET(PULLONE)=1
- SET PULLONE=2
- QUIT
- ADD ;Add Rx to SPSORX array
- +1 IF $GET(SPSORX("PSOL",1))']""
- SET SPSORX("PSOL",1)=RXREC_","
- QUIT
- +2 FOR PSOX1=0:0
- SET PSOX1=$ORDER(SPSORX("PSOL",PSOX1))
- if 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +3 IF $LENGTH(SPSORX("PSOL",PSOX2))+$LENGTH(RXREC)<220
- SET SPSORX("PSOL",PSOX2)=SPSORX("PSOL",PSOX2)_RXREC_","
- QUIT
- +4 SET SPSORX("PSOL",PSOX2+1)=RXREC_","
- +5 QUIT
- BBADD ;
- +1 NEW PSOX1,PSOX2
- +2 IF $GET(BBRX(1))']""
- SET BBRX(1)=RXREC_","
- QUIT
- +3 FOR PSOX1=0:0
- SET PSOX1=$ORDER(BBRX(PSOX1))
- if 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +4 IF $LENGTH(BBRX(PSOX2))+$LENGTH(RXREC)<220
- SET BBRX(PSOX2)=BBRX(PSOX2)_RXREC_","
- QUIT
- +5 SET BBRX(PSOX2+1)=RXREC_","
- +6 QUIT
- PPLADD ;
- +1 ; This function will move entries from the RXRS array (which has RXs that were pulled
- +2 ; from supense via the PP action on the Medication profile) to the list of RXs that
- +3 ; will get a label (PPL variable and possible PSORX array).
- +4 ; Note that arrays RXRS and PSORX and variable PPL are pre-existing
- +5 NEW SZZ,SPSOX1,SPSOX2,LSFN
- +6 IF $GET(PPL)'=""
- IF $EXTRACT(PPL,$LENGTH(PPL))'=","
- SET PPL=PPL_","
- +7 ;
- +8 ; Loop through entries in the RXRS array and process
- +9 SET SZZ=0
- FOR
- SET SZZ=$ORDER(RXRS(SZZ))
- if 'SZZ
- QUIT
- Begin DoDot:1
- +10 ; If SZZ is already set in the PPL variable do not set it again
- +11 IF $GET(PPL)[SZZ
- QUIT
- +12 ; Check if label already printed per the RX SUSPENSE file
- +13 SET LSFN=$ORDER(^PS(52.5,"B",SZZ,0))
- +14 if '$GET(LSFN)
- QUIT
- +15 if $GET(^PS(52.5,LSFN,"P"))
- QUIT
- +16 ; The following function checks for ECME conditions where we do not want a label
- +17 ; This is probably redundant as the RXRS array entry should not have been created if any of these
- +18 ; conditions existed but things might have changed after the entry was created
- +19 IF $$ECMECHK^PSOREJU3(SZZ)
- QUIT
- +20 ; Add to list of RXs that should get a label
- +21 IF $GET(PPL)=""
- SET PPL=SZZ_","
- QUIT
- +22 IF $LENGTH(PPL)+$LENGTH(SZZ)<220
- SET PPL=PPL_SZZ_","
- QUIT
- +23 IF $GET(PSORX("PSOL",2))']""
- SET PSORX("PSOL",2)=SZZ_","
- QUIT
- +24 FOR SPSOX1=1:0
- SET SPSOX1=$ORDER(PSORX("PSOL",SPSOX1))
- if 'SPSOX1
- QUIT
- SET SPSOX2=SPSOX1
- +25 IF $LENGTH(PSORX("PSOL",SPSOX2))+$LENGTH(SZZ)<220
- SET PSORX("PSOL",SPSOX2)=PSORX("PSOL",SPSOX2)_SZZ_","
- QUIT
- +26 SET PSORX("PSOL",SPSOX2+1)=SZZ_","
- End DoDot:1
- +27 QUIT
- CKDIV ;
- +1 IF '$PIECE($GET(PSOSYS),"^",2)
- WRITE !!?10,"Rx # ",$PIECE(^PSRX(RXREC,0),"^")," is not a valid choice (Different Division)"
- SET PSPOP=1
- QUIT
- +2 IF $PIECE($GET(PSOSYS),"^",3)
- WRITE !!?10
- KILL DIR
- SET DIR("A")="Rx # "_$PIECE(^PSRX(RXREC,0),"^")_" is from another division. OK to Pull"
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- IF $GET(DIRUT)!('Y)
- SET PSPOP=1
- +3 QUIT
- SELONE ;Pull one Rx through Listman
- +1 IF $GET(PSOBEDT)
- WRITE $CHAR(7),$CHAR(7)
- SET VALMSG="Invalid Action at this time !"
- SET VALMBCK=""
- QUIT
- +2 NEW ORD,MW,PDUZ,PSLST,PSOSQ,PSOSQRTE,PSOSQMTH,PSPOP,PSOX1,PSOX2,PULLONE,RXLTOP,RXREC,SFN,SORD,SORN,VALMCNT
- +3 SET PULLONE=1
- +4 IF +PSOLST(ORN)'=52
- SET VALMBCK=""
- QUIT
- +5 ;p441 mwa added unparked message
- IF +PSOLST(ORN)=52
- IF $PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"STA")),"^")'=5
- SET VALMSG="Rx is not on Suspense"_$SELECT($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),"PARK")):" and needs to be UNPARKED",1:"")_"!"
- SET VALMBCK=""
- QUIT
- +6 IF +PSOLST(ORN)=52
- IF $DATA(RXRS($PIECE(PSOLST(ORN),"^",2)))
- SET VALMSG="Pull early has already been requested!"
- SET VALMBCK=""
- QUIT
- +7 NEW EHOLDQ,ESIEN,ERXIEN
- SET ERXIEN=$PIECE(PSOLST(ORN),"^",2)
- SET ESIEN=""
- SET ESIEN=$ORDER(^PS(52.5,"B",ERXIEN,ESIEN))
- +8 IF $GET(ESIEN)
- IF $$GET1^DIQ(52.5,ESIEN,10)'=""
- DO EHOLD
- if $GET(EHOLDQ)
- QUIT
- +9 KILL EHOLDQ,ESIEN,ERXIEN
- +10 DO SELQ
- IF $GET(PULLONE)=2
- SET VALMSG="Rx# "_$PIECE($GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0)),"^")_" not pulled from suspense!"
- QUIT
- +11 IF +PSOLST(ORN)=52
- SET RXREC=$PIECE(PSOLST(ORN),"^",2)
- +12 DO BEGQ
- SET VALMSG="Rx# "_$PIECE($GET(^PSRX(+$GET(RXREC),0)),"^")_$SELECT($GET(PSOSQ):" pulled",1:" not pulled")_" from Suspense!"
- +13 SET VALMBCK="R"
- +14 QUIT
- RESET ;
- +1 NEW RSDA,RXMW,RXMP,RXSP,RXR,DA,RXPSRX,RXFILL,RXFILLN
- +2 FOR RSDA=0:0
- SET RSDA=$ORDER(RXRS(RSDA))
- if 'RSDA
- QUIT
- Begin DoDot:1
- +3 SET RXSP=$ORDER(^PS(52.5,"B",RSDA,0))
- if 'RXSP
- QUIT
- +4 if '$DATA(^PS(52.5,RXSP,0))
- QUIT
- +5 SET RXMW=$SELECT($PIECE($GET(RXRS(RSDA)),"^",2)="":"M",1:$PIECE($GET(RXRS(RSDA)),"^",2))
- SET RXMP=$PIECE($GET(RXRS(RSDA)),"^",3)
- SET RXFILL=$PIECE($GET(RXRS(RSDA)),"^",4)
- SET RXFILLN=$PIECE($GET(RXRS(RSDA)),"^",5)
- SET RXPSRX=$SELECT($PIECE($GET(RXRS(RSDA)),"^",6)="":"M",1:$PIECE($GET(RXRS(RSDA)),"^",6))
- +6 IF RXMW'=""
- SET $PIECE(^PS(52.5,RXSP,0),"^",4)=RXMW
- Begin DoDot:2
- +7 IF RXFILL="P"
- Begin DoDot:3
- +8 IF $DATA(^PSRX(RSDA,"P",+$GET(RXFILLN),0))
- SET $PIECE(^PSRX(RSDA,"P",+$GET(RXFILLN),0),"^",2)=$GET(RXPSRX)
- SET $PIECE(^PSRX(RSDA,"MP"),"^")=RXMP
- End DoDot:3
- QUIT
- +9 IF RXFILL="R"
- IF $GET(RXFILLN)
- SET DA(1)=RSDA
- SET DA=RXFILLN
- SET DIE="^PSRX("_DA(1)_",1,"
- SET DR="2////"_RXPSRX
- DO ^DIE
- KILL DIE
- +10 IF RXFILL="O"
- SET DA=RSDA
- SET DIE="^PSRX("
- SET DR="11////"_RXPSRX
- DO ^DIE
- KILL DIE
- +11 SET $PIECE(^PSRX(RSDA,"MP"),"^")=RXMP
- End DoDot:2
- End DoDot:1
- +12 QUIT
- GETMW ;
- +1 NEW GETPAR,GETRX,GETCNT
- +2 SET PSOGETF="O"
- SET PSOGETFN=""
- +3 SET GETPAR=$PIECE($GET(^PS(52.5,SFN,0)),"^",5)
- +4 IF GETPAR
- SET PSOGET=$PIECE($GET(^PSRX(RXREC,"P",GETPAR,0)),"^",2)
- SET PSOGETF="P"
- SET PSOGETFN=GETPAR
- QUIT
- +5 IF '$ORDER(^PSRX(RXREC,1,0))
- SET PSOGET=$PIECE($GET(^PSRX(RXREC,0)),"^",11)
- QUIT
- +6 SET GETRX=0
- FOR GETCNT=0:0
- SET GETCNT=$ORDER(^PSRX(RXREC,1,GETCNT))
- if 'GETCNT
- QUIT
- SET GETRX=GETCNT
- +7 SET PSOGET=$PIECE($GET(^PSRX(RXREC,1,+$GET(GETRX),0)),"^",2)
- SET PSOGETF="R"
- SET PSOGETFN=+$GET(GETRX)
- +8 QUIT
- ULRX ;
- +1 IF '$GET(RXREC)
- QUIT
- +2 DO PSOUL^PSSLOCK(RXREC)
- +3 QUIT
- EHOLD ;
- +1 if '$GET(ERXIEN)
- QUIT
- +2 if $$GET1^DIQ(52,ERXIEN,86)=""
- QUIT
- +3 DO FULL^VALM1
- +4 WRITE !,"This is an ePharmacy billable fill which is Suspended until "_$$GET1^DIQ(52.5,ESIEN,10)_", based"
- +5 WRITE !,"on the 3/4 Days rule.",!
- +6 KILL DIR
- SET EHOLDQ=0
- SET DIR(0)="YA"
- SET DIR("A")="Do you wish to continue? "
- +7 DO ^DIR
- IF $DATA(DIRUT)!('Y)
- SET EHOLDQ=1
- KILL DIR
- +8 SET VALMSG="No action taken."
- SET VALMBCK="R"
- +9 QUIT
- +10 ;