PSOREJP3 ;ALB/SS - Third Party Reject Display Screen - Comments ;10/27/06
;;7.0;OUTPATIENT PHARMACY;**260,287,289,290,358,359,385,403,421,427,448,482,512,528,544**;DEC 1997;Build 19
;Reference to GETDAT^BPSBUTL supported by IA 4719
;Reference to COM^BPSSCRU3 supported by IA 6214
;Reference to IEN59^BPSOSRX supported by IA 4412
;Reference to GETPL59^BPSPRRX5 supported by IA 6939
;Reference to GETRTP59^BPSPRRX5 supported by IA 6939
;
COM ; Builds the Comments section in the Reject Information Screen.
; The following variables are assumed to exist:
; RX - Pointer to file# 52, Prescription.
; FILL - Pointer to the Refill sub-file of the Prescription.
; REJ - Pointer to the Reject Info sub-file of the Prescription.
;
N PSOARRAY,PSOCNT,PSOCOM,PSODATA,PSODATE,PSODATE1,PSODFN,PSOLAST,PSOPC
N PSOPFLAG,PSOSTATUS,PSOSTR,PSOTEMP,PSOUSER,PSOX,PSOY,X
;
; MRD;PSO*7*448 - This patch added the ability for an OPECC to flag a
; comment on a BPS Transaction as being for pharmacy. A comment so
; flagged will appear on the Reject Information Screen intermingled
; with any other comments on the Prescription. All the comments will
; be sorted in reverse chronological order.
;
; COM^BPSSCRU3 populates the array PSOTEMP with all the comments from
; the BPS Transaction corresponding to the Prescription and Refill.
; Any of those comments with the Pharmacy flag set to '1' will be
; added to the array PSOARRAY.
;
D COM^BPSSCRU3(RX,FILL,,.PSOTEMP) ; IA 6214.
;
S PSODATE=0
F S PSODATE=$O(PSOTEMP(PSODATE)) Q:'PSODATE D
. S PSOX=0
. F S PSOX=$O(PSOTEMP(PSODATE,PSOX)) Q:'PSOX D
. . ;
. . ; If the Pharmacy flag is set, then add this comment to the
. . ; array PSOARRAY to be displayed.
. . ;
. . S PSOPFLAG=$P(PSOTEMP(PSODATE,PSOX),U)
. . I 'PSOPFLAG Q
. . S PSOCOM=$P(PSOTEMP(PSODATE,PSOX),U,2)
. . S PSOUSER=$P(PSOTEMP(PSODATE,PSOX),U,3)
. . S PSOUSER=$$GET1^DIQ(200,PSOUSER,.01)
. . S PSOY=$$FMTE^XLFDT(PSODATE)
. . S PSOCOM=PSOY_" (OPECC) - "_PSOCOM_" ("_PSOUSER_")"
. . S PSOY=$G(PSOARRAY(PSODATE))+1
. . S PSOARRAY(PSODATE)=PSOY
. . S PSOARRAY(PSODATE,PSOY)=PSOCOM
. . Q
. Q
;
; Pull comments from the Reject sub-file of the Prescription and
; add to the array PSOARRAY.
;
S PSOX=0
F S PSOX=$O(^PSRX(RX,"REJ",REJ,"COM",PSOX)) Q:'PSOX D
. S PSODATE=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,.01,"E")
. S PSOUSER=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,1)
. S PSOCOM=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,2)
. S PSOCOM=PSODATE_" - "_PSOCOM_" ("_PSOUSER_")"
. S PSODATE=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,.01,"I")
. S PSOY=$G(PSOARRAY(PSODATE))+1
. S PSOARRAY(PSODATE)=PSOY
. S PSOARRAY(PSODATE,PSOY)=PSOCOM
. Q
;
; At this point, all of the comments to be displayed are in the array
; PSOARRAY, sorted by date/time. If that array is empty, then skip
; down to PTC. Otherwise, loop through the comments backwards to
; display in reverse chronological order.
;
I '$O(PSOARRAY("")) G PTC
D SETLN^PSOREJP1()
D SETLN^PSOREJP1("COMMENTS - REJECT",1,1)
;
S PSODATE=""
F S PSODATE=$O(PSOARRAY(PSODATE),-1) Q:'PSODATE D
. S PSOX=""
. F S PSOX=$O(PSOARRAY(PSODATE,PSOX),-1) Q:'PSOX D
. . ;
. . ; Use ^DIWP utility to put comment into scratch global array,
. . ; with lines broken apart intelligently.
. . ;
. . N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
. . K ^UTILITY($J,"W")
. . S X=PSOARRAY(PSODATE,PSOX)
. . S DIWL=1
. . S DIWR=78
. . D ^DIWP
. . ;
. . ; Loop through the scratch array and add each line to the ^TMP
. . ; global to be displayed on the screen.
. . ;
. . S PSOLAST=0
. . F PSOY=1:1 Q:('$D(^UTILITY($J,"W",1,PSOY,0))) D
. . . S PSOCOM=$G(^UTILITY($J,"W",1,PSOY,0))
. . . ;
. . . ; If this line is the last of this comment, and this is the
. . . ; last comment, then Set PSOLAST=1 to make this line underlined
. . . ; on the screen.
. . . ;
. . . I '$D(^UTILITY($J,"W",1,PSOY+1)),$O(PSOARRAY(PSODATE,PSOX),-1)="",$O(PSOARRAY(PSODATE),-1)="" S PSOLAST=1
. . . ;
. . . ; Use SETLN^PSOREJP1 to add line to ^TMP array to be displayed to screen.
. . . ;
. . . D SETLN^PSOREJP1($S(PSOY=1:"- ",1:" ")_PSOCOM,0,PSOLAST,1)
. . . Q
. . Q
. Q
;
PTC ; Patient Comments
;
K PSOARRAY
;
; Get Patient ID - If no Patient Comments on file, Quit
S PSODFN=$$GET1^DIQ(52,RX,2,"I")
I '$D(^PS(55,PSODFN,"PC")) Q
;
; Loop through Patient Comments - Add ACTIVE Comments to PSOAR array
S PSODATE=""
S PSOCNT=0
K PSOAR
F S PSODATE=$O(^PS(55,PSODFN,"PC","B",PSODATE)) Q:PSODATE="" D
. S PSOPC=""
. F S PSOPC=$O(^PS(55,PSODFN,"PC","B",PSODATE,PSOPC)) Q:PSOPC="" D
. . K PSODATA
. . D GETS^DIQ(55.17,PSOPC_","_PSODFN_",",".01;1;2;3","IE","PSODATA")
. . ;
. . ; Only display ACTIVE Patient Comments
. . S PSOSTATUS=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",2,"I"))
. . I PSOSTATUS'="Y" Q
. . ;
. . S PSODATE1=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",.01,"E"))
. . S PSOUSER=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",1,"E"))
. . S PSOCOM=$G(PSODATA(55.17,PSOPC_","_PSODFN_",",3,"E"))
. . S PSOSTR=PSODATE1_" - "_PSOCOM_" ("_PSOUSER_")"
. . S PSOCNT=PSOCNT+1
. . S PSOARRAY(PSOCNT)=PSOSTR
;
; If PSOAR array exists, display Active Patient Comments
I $D(PSOARRAY) D
. D SETLN^PSOREJP1("COMMENTS - PATIENT",1,1)
. ;
. ; Loop through PSOAR in reverse order to display Patient
. ; Comments in reverse chronological order
. S PSOCNT=""
. F S PSOCNT=$O(PSOARRAY(PSOCNT),-1) Q:PSOCNT="" D
. . ;
. . ; Use ^DIWP to display Patient Comments with proper
. . ; line breaking
. . N %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
. . K ^UTILITY($J,"W")
. . S X=PSOARRAY(PSOCNT)
. . S DIWL=1
. . S DIWR=78
. . D ^DIWP
. . ;
. . S PSOLAST=0
. . F PSOY=1:1 Q:('$D(^UTILITY($J,"W",1,PSOY,0))) D
. . . S PSOCOM=$G(^UTILITY($J,"W",1,PSOY,0))
. . . ;
. . . ; Looping through the array in reverse order means PSOCNT=1
. . . ; will be the last comment to display. If the last line of the
. . . ; last comment is being displayed, set PSOLAST=1 to underline
. . . ; the comment on the screen.
. . . ;
. . . I '$D(^UTILITY($J,"W",1,PSOY+1)),PSOCNT=1 S PSOLAST=1
. . . ;
. . . ; Use SETLN^PSOREJP1 to add line to ^TMP array to be displayed to screen.
. . . ;
. . . D SETLN^PSOREJP1($S(PSOY=1:"- ",1:" ")_PSOCOM,0,PSOLAST,1)
;
K ^UTILITY($J,"W")
;
Q
;
ADDCOM ; - Add comment worklist action
N DIR,PSO55,PSCOM,PSOCOMTYPE
D FULL^VALM1
;
S DIR(0)="S^R:Reject;P:Patient Billing"
S DIR("A")="Comment Type"
S DIR("?",1)="The Reject Comment only displays for the specific reject."
S DIR("?")="The Patient Billing Comment displays on all rejects for the patient."
D ^DIR
I $D(DIRUT) S VALMBCK="R" Q
S PSOCOMTYPE=Y
;
I PSOCOMTYPE="P",'$D(^XUSEC("PSO EPHARMACY SITE MANAGER",DUZ)) D S VALMBCK="R" Q
. W !,"Patient Billing Comments require Pharmacy Key (PSO EPHARMACY SITE MANAGER)"
. D WAIT^VALM1
;
S PSCOM=$$COMMENT("Comment: ",150)
;
; Save Reject Type Comment
I PSOCOMTYPE="R",$L(PSCOM)>0,PSCOM'["^" D
. D SAVECOM(RX,REJ,PSCOM) ;save the comment
. D INIT^PSOREJP1 ;update screen
; Save Patient Billing Type Comment
I PSOCOMTYPE="P",$L(PSCOM)>0,PSCOM'["^" D
. S PSO55=$$GET1^DIQ(52,RX,2,"I")
. D ADDPC^PSOPTC0(PSCOM,PSO55)
. D INIT^PSOREJP1
S VALMBCK="R"
Q
;
;Enter a comment
;PSOTR -prompt string
;PSMLEN -maxlen
;returns:
; "^" - if user chose to quit
; "" - nothing entered or input has been discarded
; otherwise - comment's text
N DIR,DTOUT,DUOUT,PSQ
I '$D(PSOTR) S PSOTR="Comment "
I '$D(PSMLEN) S PSMLEN=150
S DIR(0)="FA^1:150"
S DIR("A")=PSOTR
S DIR("?")="Enter a free text comment up to 150 characters long."
S PSQ=0
F D Q:+PSQ'=0
. W ! D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S PSQ=-1 Q
. I $L(Y)'>PSMLEN S PSQ=1 Q
. W !!,"Enter a free text comment up to 150 characters long.",!
. S DIR("B")=$E(Y,1,PSMLEN)
Q:PSQ<0 "^"
Q:$L(Y)=0 ""
S PSQ=$$YESNO("Confirm","YES")
I PSQ=-1 Q "^"
I PSQ=0 Q ""
Q Y
;
; Ask
; Input:
; PSQSTR - question
; PSDFL - default answer
; Output:
; 1 YES
; 0 NO
; -1 if cancelled
YESNO(PSQSTR,PSDFL) ; Default - YES
N DIR,Y,DUOUT
S DIR(0)="Y"
S DIR("A")=PSQSTR
S:$L($G(PSDFL)) DIR("B")=PSDFL
W ! D ^DIR
Q $S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y)
;
;Save comment
SAVECOM(PSRXIEN,PSREJIEN,PSCOMNT,DATETIME,USER) ;
N PSREC,PSDA,PSERR
I '$G(DATETIME) D NOW^%DTC S DATETIME=%
I '$G(USER) S USER=DUZ
D INSITEM(52.2551,PSRXIEN,PSREJIEN,DATETIME)
S PSREC=$O(^PSRX(PSRXIEN,"REJ",PSREJIEN,"COM","B",DATETIME,0))
I PSREC>0 D
. S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",1)=USER
. S PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",2)=$G(PSCOMNT)
. D FILE^DIE("","PSDA","PSERR")
Q
;
;/**
;PSSFILE - subfile# (52.2551) for comment
;PSIEN - ien for file in which the new subfile entry will be inserted
;PSVAL01 - .01 value for the new entry
INSITEM(PSSFILE,PSIEN0,PSIEN1,PSVAL01) ;*/
N PSSSI,PSIENS,PSFDA,PSER
S PSIENS="+1,"_PSIEN1_","_PSIEN0_","
S PSFDA(PSSFILE,PSIENS,.01)=PSVAL01
D UPDATE^DIE("","PSFDA","PSSSI","PSER")
I $D(PSER) D BMES^XPDUTL(PSER("DIERR",1,"TEXT",1))
Q
;
PRINT(RX,RFL) ; Print Label for specific Rx/Fill
I '$G(RX) Q
I $G(RFL)="" Q
;
; Some of these variables are used by LBL^PSOLSET but they are newed here
N PPL,PSOSITE,PSOPAR,PSOSYS,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG,PSOCLBL
N PSOQUIT,PSOPIOST,PSOLTEST,PSOTLBL,PSORXT
N DFN,PDUZ,RXFL,REPRINT,REJLBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
N %ZIS,IOP,POP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTDTH,VAR
;
; Set the default label printer. We need to new it so we don't change the value that was
; set by PSOLSET when the user first logged into OP so need to do a bit of work to new it and
; reset it before the call to LBL^PSOLSET.
I $G(PSOLAP)]"" S PSOTLBL=PSOLAP N PSOLAP S PSOLAP=PSOTLBL,PSOCLBL=1
E N PSOLAP S PSOCLBL=""
;
; Check if a label has already been printed and set REPRINT flag.
S REJLBL=0 F S REJLBL=$O(^PSRX(RX,"L",REJLBL)) Q:'REJLBL I +$$GET1^DIQ(52.032,REJLBL_","_RX,1,"I")=RFL S REPRINT=1 Q
;
; Define required variables
S PSOSITE=+$$RXSITE^PSOBPSUT(RX,RFL),PSOPAR=$G(^PS(59,PSOSITE,1))
S DFN=$$GET1^DIQ(52,RX,2,"I"),PDUZ=DUZ,PSOSYS=$G(^PS(59.7,1,40.1))
S PPL=RX I RFL S RXFL(RX)=RFL
;
; Get label print device and check alignment
W ! S PSOBFLAG=1 D LBL^PSOLSET I $G(PSOQUIT) Q
I $G(PSOLAP)="" W $C(7),!!,"No printer defined" K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR Q
;
; Call %ZIS to get device characteristics w/o reopening the printer.
; We need to do this to check if queuing is forced for this device
; Not checking the POP variable. If we don't get the device here, we will fall through to the
; foreground process and try again
S IOP=PSOLAP,%ZIS="QN" D ^%ZIS
;
; If background printer, queue the job
I $D(IO("Q")) D Q
. S ZTRTN="DQ^PSOLBL",ZTDTH=$H,ZTIO=PSOLAP
. F VAR="PSOSYS","DFN","PSOPAR","PDUZ","PCOMX","PSOLAP","PPL","PSOSITE","RXY","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP","REPRINT" S:$D(@VAR) ZTSAVE(VAR)=""
. S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
. S ZTDESC="OUTPATIENT PHARMACY REJECT WORKLIST LABEL PRINT"
. D ^%ZISC,^%ZTLOAD
. W !!,"Label ",$S('$D(ZTSK):"NOT ",1:""),"queued to print",! I '$D(ZTSK) W $C(7) K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR
;
; If we gotten this far, open the device and print the label in the foreground
; We also need to preserve the PSORX array, which gets killed by DQ^PSOLBL
K %ZIS S IOP=PSOLAP D ^%ZIS
I POP D ^%ZISC W $C(7),!!,"Printer is busy - NO label printed" K DIR S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR Q
K PSORXT M PSORXT=PSORX
D DQ^PSOLBL,^%ZISC
K PSORX M PSORX=PSORXT
Q
;
RXINFO(RX,FILL,LINE,REJ) ; Returns header displayable Rx Information
N TXT,RXINFO,LBL,CMOP,DRG,PSOET
I LINE=1 D
. N RXDOS D GETDAT^BPSBUTL(RX,FILL,,.RXDOS) ; Get Date of Service from BPS CLAIM field 401 - PSO*7*421
. S RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
. ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable
. S PSOET=$$PSOET(RX,FILL)
. S $E(RXINFO,27)="ECME#: "_$S(PSOET:"",1:$$ECMENUM^PSOBPSU2(RX,FILL))
. S $E(RXINFO,49)="Date of Service: "_$S(PSOET:"",1:$$FMTE^XLFDT(RXDOS)) ; Use DOS from BPS Claims field 401 - PSO*7*421
I LINE=2 D
. S DRG=$$GET1^DIQ(52,RX,6,"I"),CMOP=$S($D(^PSDRUG("AQ",DRG)):1,1:0)
. S RXINFO=$S(CMOP:"CMOP ",1:"")_"Drug",$E(RXINFO,10)=": "_$E($$GET1^DIQ(52,RX,6),1,43)
. S $E(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
Q $G(RXINFO)
;
FILL ;Fill payable TRICARE or CHAMPVA Rx
N COM,I,OPNREJ,OPNREJ2,OPNREJ3,DCSTAT,PSOREL
S:'$G(PSOTRIC) PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC) ;cnf, PSO*7*358, add line
;cnf, PSO*7*358, don't allow option if TRICARE/CHAMPVA and released, PSOREL is set to the release date
S PSOREL=0 I PSOTRIC D
. I 'FILL S PSOREL=+$$GET1^DIQ(52,RX,31,"I")
. I FILL S PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I")
I PSOREL S VALMSG="Released Rxs may not be filled.",VALMBCK="R" Q
;cnf, PSO*7*358, don't allow option if prescription has been discontinued
; 12 - DISCONTINUED
; 14 - DISCONTINUED BY PROVIDER
; 15 - DISCONTINUED (EDIT)
S DCSTAT=$$GET1^DIQ(52,RX,100,"I")
I "/12/14/15/"[("/"_DCSTAT_"/") S VALMSG="Discontinued Rxs may not be filled.",VALMBCK="R" Q
D FULL^VALM1
I $$CLOSED^PSOREJP1(RX,REJ) D Q
. S VALMSG="This Reject is marked resolved!",VALMBCK="R"
;cnf, PSO*7*358
S COM=""
I 'PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE") S VALMSG="Only Rxs with an E PAYABLE status may be filled.",VALMBCK="R" Q
I PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE") D FILLTR I $L($G(VALMSG)_$G(VALMBCK)) Q ;cnf, PSO*7*358
S:COM="" COM="AUTOMATICALLY CLOSED" ;cnf, PSO*7*358, add condition
S (OPNREJ,OPNREJ2,OPNREJ3)=""
S OPNREJ2=0 F S OPNREJ2=$O(^PSRX(RX,"REJ",OPNREJ2)) Q:OPNREJ2=""!(OPNREJ2'?1N.N) S OPNREJ=OPNREJ_","_OPNREJ2
S OPNREJ=$E(OPNREJ,2,999),OPNREJ2=""
W !?20,"[Closing all rejections for prescription "_$$GET1^DIQ(52,RX,".01")_":"
F I=1:1 S OPNREJ2=$P(OPNREJ,",",I) Q:OPNREJ2="" D
. S OPNREJ3="",OPNREJ3=$$GET1^DIQ(52.25,OPNREJ2_","_RX,".01")
. W !?25,OPNREJ3_" - "_$$GET1^DIQ(9002313.93,OPNREJ3,".02")_"..."
. D CLOSE^PSOREJUT(RX,FILL,OPNREJ2,DUZ,6,COM,"","","","","",1) W "OK]",!,$C(7) H 1 ; pso*7*421 Use 12th param to ignore
I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
S CHANGE=1 ;cnf, PSO*7*358, remove S VALMBCK="R" so user goes back to selection list
Q
;
PSOCOB(RX,FILL,REJ) ; Returns RXCOB indicator for Worklist
N DATA1
D GET^PSOREJU2(RX,FILL,.DATA1,REJ,1)
I $G(DATA1(REJ,"COB"))="PRIMARY" Q 1
I $G(DATA1(REJ,"COB"))="" Q 1
Q 2
;
DC ;Discontinue TRICARE Rx
N ACTION S ACTION="D"
D FULL^VALM1
S ACTION=$$DC^PSOREJU1(RX,ACTION)
I ACTION="Q"!(ACTION="^") S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q
S CHANGE=1
Q
;
FILLTR ;TRICARE/CHAMPVA specific logic ;cnf, PSO*7*358
;COM is not new'd so the variable can be used in FILL tag
N CONT,PSOETEC,PSQSTR
;
FILLTR2 ;Use for looping if user enters ^ in required comment field ;cnf, PSO*7*358
;
;if TRICARE/CHAMPVA, not payable, and no security key, quit
;reference to ^XUSEC( supported by IA 10076
I '$D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key",VALMBCK="R" Q
;
;if TRICARE/CHAMPVA, not payable, and user has security key, prompt to continue or not
S PSQSTR="You are bypassing claims processing. Do you wish to continue"
S CONT=$$YESNO(PSQSTR,"No")
I (CONT=-1)!('CONT) S VALMSG="NO ACTION TAKEN.",VALMBCK="R" Q
;
;check for valid electronic signature
I '$$SIG^PSOREJU1() S VALMBCK="R" Q ;quit if no valid electronic signature
;
;prompt user for required TRICARE/CHAMPVA Justification
S COM=$$TCOM(RX,FILL) G:COM="^" FILLTR2 ;loop back to "continue?" question if ^ entry
;
;audit log
S PSOETEC=$$PSOETEC^PSOREJP5(RX,FILL)
D AUDIT^PSOTRI(RX,FILL,,COM,$S(PSOETEC:"N",1:"R"),$S($G(PSOTRIC)=1:"T",$G(PSOTRIC)=2:"C",1:""))
Q
;
TCOM(RX,RFL) ; - Ask for TRICARE or CHAMPVA Justification
N COM,DIR,DIRUT,X
W ! S DIR(0)="F^3:100" S DIR("A")=$$ELIGDISP^PSOREJP1(RX,RFL)_" Justification" D ^DIR
S COM=X I $D(DIRUT) S COM="^"
Q COM
;
PSOET(RX,FILL) ; Returns flag for TRICARE or CHAMPVA non-billable and no claim submitted
; Return 1 if rejection code is eT or eC (pseudo-reject code)
; 0 otherwise
;
I '$G(RX) Q 0
N X,TRIREJCD
S X=0
S TRIREJCD=$T(TRIREJCD+1),TRIREJCD=$P(TRIREJCD,";;",2)
S X=$$FIND^PSOREJUT(RX,$G(FILL),,TRIREJCD,1) ; PSO*7*421 - Pass indicator to ignore ECME status
Q X
;
TRIREJCD ;TRICARE or CHAMPVA Reject Code, non-billable Rx ;cnf, PSO*7*358
;;eT,eC;;TRICARE or CHAMPVA pseudo reject codes referenced in ^PSOREJP3, ^PSOREJU4
Q
;
SEND(OVRCOD,CLA,PA,PSOET) ; - Sends Claim to ECME and closes Reject
; Input: OVRCOD - Up to three ~-pieces, and each populated would be
; Reason for Service Code ^ Prof Srvc Cd ^ Result of Srvc Cd
; CLA - Submission Clarification Code #1 ~ SCC #2 ~ SCC #3
; PA - Prior Auth Type ^ Prior Auth Number
; PSOET - 1 if eT/eC pseudo-reject on claim
N ALTXT,COM,DIR,PSO59,PSOCOB,PSOETEC,PSOPLAN,PSORTYPE,RESP,SMA
N DIWF,DIWL,DIWR,X
S DIR(0)="Y",DIR("A")=" Confirm",DIR("B")="YES"
S DIR("A",1)=" When you confirm, a new claim will be submitted for"
S DIR("A",2)=" the prescription and this REJECT will be marked"
S DIR("A",3)=" resolved."
S DIR("A",4)=" "
W ! D ^DIR K DIR I $G(Y)=0!$D(DIRUT) S VALMBCK="R" Q
S SMA=0 I $G(OVRCOD)]"",$G(CLA)]"",$G(PA)]"" S SMA=1
S ALTXT=""
I 'SMA D
. S ALTXT="REJECT WORKLIST"
. S:$G(OVRCOD)'="" ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$TR(OVRCOD,"^","/")_")"
. S:$G(CLA)]"" ALTXT=ALTXT_"-(CLARIF. CODE="_CLA_")"
. S:$G(PA)]"" ALTXT=ALTXT_"-(PRIOR AUTH.="_$TR(PA,"^","/")_")"
;
S PSOCOB=$$PSOCOB^PSOREJP3(RX,FILL,REJ)
S PSO59=$$IEN59^BPSOSRX(RX,FILL,PSOCOB)
S PSOPLAN=$$GETPL59^BPSPRRX5(PSO59) ; IA 6939
S PSORTYPE=$$GETRTP59^BPSPRRX5(PSO59) ; IA 6939
; Check for Tricare/Champva Non-Billable eT,eC pseudo reject set PSOETEC=1
S PSOETEC=""
I ($D(^PSRX(RX,"REJ","B","eT")))!($D(^PSRX(RX,"REJ","B","eC"))) S PSOETEC=1
;
D ECMESND^PSOBPSU1(RX,FILL,,$S($G(PSOET):"RSNB",1:"ED"),$$GETNDC^PSONDCUT(RX,FILL),,,$G(OVRCOD),,.RESP,,ALTXT,$G(CLA),$G(PA),PSOCOB,,PSOPLAN,PSORTYPE)
;If PSOETEC=1 RESP will exist because its a Non-Billable Rx, do not Quit continue processing
I PSOETEC'=1 I $G(RESP) D Q
. W !!?10,"Claim could not be submitted. Please try again later!"
. I $P(RESP,"^",2)="" S X="Reason: UNKNOWN"
. E S X="Reason: "_$P(RESP,"^",2)
. S DIWF="W"
. S DIWL=11
. S DIWR=75
. D ^DIWP
. D ^DIWW
. W $C(7)
. H 2
;
; Get the ePharmacy Response Pause and hang for that amount of time (default is 2 if not set)
N PAUSE,IEN5286
I $G(PSOSITE)="" N PSOSITE S PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL)
S IEN5286=$O(^PS(52.86,"B",+PSOSITE,""))
S PAUSE=$$GET1^DIQ(52.86,IEN5286_",",6)
I PAUSE="" S PAUSE=2
I PAUSE H PAUSE
;
I $$PTLBL^PSOREJP2(RX,FILL) D PRINT(RX,FILL)
N PSOTRIC S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
I $$GET1^DIQ(52,RX,100,"I")=5&(PSOTRIC) D
. Q:$$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE"
. N XXX S XXX=""
. W !,"This prescription can be pulled early from suspense or the label will print"
. W !,"when PRINT FROM SUSPENSE occurs.",!
. R !,"Press enter to continue... ",XXX:60
I $D(PSOSTFLT),PSOSTFLT'="B" S CHANGE=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOREJP3 19938 printed Oct 16, 2024@18:34:12 Page 2
PSOREJP3 ;ALB/SS - Third Party Reject Display Screen - Comments ;10/27/06
+1 ;;7.0;OUTPATIENT PHARMACY;**260,287,289,290,358,359,385,403,421,427,448,482,512,528,544**;DEC 1997;Build 19
+2 ;Reference to GETDAT^BPSBUTL supported by IA 4719
+3 ;Reference to COM^BPSSCRU3 supported by IA 6214
+4 ;Reference to IEN59^BPSOSRX supported by IA 4412
+5 ;Reference to GETPL59^BPSPRRX5 supported by IA 6939
+6 ;Reference to GETRTP59^BPSPRRX5 supported by IA 6939
+7 ;
COM ; Builds the Comments section in the Reject Information Screen.
+1 ; The following variables are assumed to exist:
+2 ; RX - Pointer to file# 52, Prescription.
+3 ; FILL - Pointer to the Refill sub-file of the Prescription.
+4 ; REJ - Pointer to the Reject Info sub-file of the Prescription.
+5 ;
+6 NEW PSOARRAY,PSOCNT,PSOCOM,PSODATA,PSODATE,PSODATE1,PSODFN,PSOLAST,PSOPC
+7 NEW PSOPFLAG,PSOSTATUS,PSOSTR,PSOTEMP,PSOUSER,PSOX,PSOY,X
+8 ;
+9 ; MRD;PSO*7*448 - This patch added the ability for an OPECC to flag a
+10 ; comment on a BPS Transaction as being for pharmacy. A comment so
+11 ; flagged will appear on the Reject Information Screen intermingled
+12 ; with any other comments on the Prescription. All the comments will
+13 ; be sorted in reverse chronological order.
+14 ;
+15 ; COM^BPSSCRU3 populates the array PSOTEMP with all the comments from
+16 ; the BPS Transaction corresponding to the Prescription and Refill.
+17 ; Any of those comments with the Pharmacy flag set to '1' will be
+18 ; added to the array PSOARRAY.
+19 ;
+20 ; IA 6214.
DO COM^BPSSCRU3(RX,FILL,,.PSOTEMP)
+21 ;
+22 SET PSODATE=0
+23 FOR
SET PSODATE=$ORDER(PSOTEMP(PSODATE))
if 'PSODATE
QUIT
Begin DoDot:1
+24 SET PSOX=0
+25 FOR
SET PSOX=$ORDER(PSOTEMP(PSODATE,PSOX))
if 'PSOX
QUIT
Begin DoDot:2
+26 ;
+27 ; If the Pharmacy flag is set, then add this comment to the
+28 ; array PSOARRAY to be displayed.
+29 ;
+30 SET PSOPFLAG=$PIECE(PSOTEMP(PSODATE,PSOX),U)
+31 IF 'PSOPFLAG
QUIT
+32 SET PSOCOM=$PIECE(PSOTEMP(PSODATE,PSOX),U,2)
+33 SET PSOUSER=$PIECE(PSOTEMP(PSODATE,PSOX),U,3)
+34 SET PSOUSER=$$GET1^DIQ(200,PSOUSER,.01)
+35 SET PSOY=$$FMTE^XLFDT(PSODATE)
+36 SET PSOCOM=PSOY_" (OPECC) - "_PSOCOM_" ("_PSOUSER_")"
+37 SET PSOY=$GET(PSOARRAY(PSODATE))+1
+38 SET PSOARRAY(PSODATE)=PSOY
+39 SET PSOARRAY(PSODATE,PSOY)=PSOCOM
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 ;
+43 ; Pull comments from the Reject sub-file of the Prescription and
+44 ; add to the array PSOARRAY.
+45 ;
+46 SET PSOX=0
+47 FOR
SET PSOX=$ORDER(^PSRX(RX,"REJ",REJ,"COM",PSOX))
if 'PSOX
QUIT
Begin DoDot:1
+48 SET PSODATE=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,.01,"E")
+49 SET PSOUSER=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,1)
+50 SET PSOCOM=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,2)
+51 SET PSOCOM=PSODATE_" - "_PSOCOM_" ("_PSOUSER_")"
+52 SET PSODATE=$$GET1^DIQ(52.2551,PSOX_","_REJ_","_RX,.01,"I")
+53 SET PSOY=$GET(PSOARRAY(PSODATE))+1
+54 SET PSOARRAY(PSODATE)=PSOY
+55 SET PSOARRAY(PSODATE,PSOY)=PSOCOM
+56 QUIT
End DoDot:1
+57 ;
+58 ; At this point, all of the comments to be displayed are in the array
+59 ; PSOARRAY, sorted by date/time. If that array is empty, then skip
+60 ; down to PTC. Otherwise, loop through the comments backwards to
+61 ; display in reverse chronological order.
+62 ;
+63 IF '$ORDER(PSOARRAY(""))
GOTO PTC
+64 DO SETLN^PSOREJP1()
+65 DO SETLN^PSOREJP1("COMMENTS - REJECT",1,1)
+66 ;
+67 SET PSODATE=""
+68 FOR
SET PSODATE=$ORDER(PSOARRAY(PSODATE),-1)
if 'PSODATE
QUIT
Begin DoDot:1
+69 SET PSOX=""
+70 FOR
SET PSOX=$ORDER(PSOARRAY(PSODATE,PSOX),-1)
if 'PSOX
QUIT
Begin DoDot:2
+71 ;
+72 ; Use ^DIWP utility to put comment into scratch global array,
+73 ; with lines broken apart intelligently.
+74 ;
+75 NEW %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
+76 KILL ^UTILITY($JOB,"W")
+77 SET X=PSOARRAY(PSODATE,PSOX)
+78 SET DIWL=1
+79 SET DIWR=78
+80 DO ^DIWP
+81 ;
+82 ; Loop through the scratch array and add each line to the ^TMP
+83 ; global to be displayed on the screen.
+84 ;
+85 SET PSOLAST=0
+86 FOR PSOY=1:1
if ('$DATA(^UTILITY($JOB,"W",1,PSOY,0)))
QUIT
Begin DoDot:3
+87 SET PSOCOM=$GET(^UTILITY($JOB,"W",1,PSOY,0))
+88 ;
+89 ; If this line is the last of this comment, and this is the
+90 ; last comment, then Set PSOLAST=1 to make this line underlined
+91 ; on the screen.
+92 ;
+93 IF '$DATA(^UTILITY($JOB,"W",1,PSOY+1))
IF $ORDER(PSOARRAY(PSODATE,PSOX),-1)=""
IF $ORDER(PSOARRAY(PSODATE),-1)=""
SET PSOLAST=1
+94 ;
+95 ; Use SETLN^PSOREJP1 to add line to ^TMP array to be displayed to screen.
+96 ;
+97 DO SETLN^PSOREJP1($SELECT(PSOY=1:"- ",1:" ")_PSOCOM,0,PSOLAST,1)
+98 QUIT
End DoDot:3
+99 QUIT
End DoDot:2
+100 QUIT
End DoDot:1
+101 ;
PTC ; Patient Comments
+1 ;
+2 KILL PSOARRAY
+3 ;
+4 ; Get Patient ID - If no Patient Comments on file, Quit
+5 SET PSODFN=$$GET1^DIQ(52,RX,2,"I")
+6 IF '$DATA(^PS(55,PSODFN,"PC"))
QUIT
+7 ;
+8 ; Loop through Patient Comments - Add ACTIVE Comments to PSOAR array
+9 SET PSODATE=""
+10 SET PSOCNT=0
+11 KILL PSOAR
+12 FOR
SET PSODATE=$ORDER(^PS(55,PSODFN,"PC","B",PSODATE))
if PSODATE=""
QUIT
Begin DoDot:1
+13 SET PSOPC=""
+14 FOR
SET PSOPC=$ORDER(^PS(55,PSODFN,"PC","B",PSODATE,PSOPC))
if PSOPC=""
QUIT
Begin DoDot:2
+15 KILL PSODATA
+16 DO GETS^DIQ(55.17,PSOPC_","_PSODFN_",",".01;1;2;3","IE","PSODATA")
+17 ;
+18 ; Only display ACTIVE Patient Comments
+19 SET PSOSTATUS=$GET(PSODATA(55.17,PSOPC_","_PSODFN_",",2,"I"))
+20 IF PSOSTATUS'="Y"
QUIT
+21 ;
+22 SET PSODATE1=$GET(PSODATA(55.17,PSOPC_","_PSODFN_",",.01,"E"))
+23 SET PSOUSER=$GET(PSODATA(55.17,PSOPC_","_PSODFN_",",1,"E"))
+24 SET PSOCOM=$GET(PSODATA(55.17,PSOPC_","_PSODFN_",",3,"E"))
+25 SET PSOSTR=PSODATE1_" - "_PSOCOM_" ("_PSOUSER_")"
+26 SET PSOCNT=PSOCNT+1
+27 SET PSOARRAY(PSOCNT)=PSOSTR
End DoDot:2
End DoDot:1
+28 ;
+29 ; If PSOAR array exists, display Active Patient Comments
+30 IF $DATA(PSOARRAY)
Begin DoDot:1
+31 DO SETLN^PSOREJP1("COMMENTS - PATIENT",1,1)
+32 ;
+33 ; Loop through PSOAR in reverse order to display Patient
+34 ; Comments in reverse chronological order
+35 SET PSOCNT=""
+36 FOR
SET PSOCNT=$ORDER(PSOARRAY(PSOCNT),-1)
if PSOCNT=""
QUIT
Begin DoDot:2
+37 ;
+38 ; Use ^DIWP to display Patient Comments with proper
+39 ; line breaking
+40 NEW %,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z
+41 KILL ^UTILITY($JOB,"W")
+42 SET X=PSOARRAY(PSOCNT)
+43 SET DIWL=1
+44 SET DIWR=78
+45 DO ^DIWP
+46 ;
+47 SET PSOLAST=0
+48 FOR PSOY=1:1
if ('$DATA(^UTILITY($JOB,"W",1,PSOY,0)))
QUIT
Begin DoDot:3
+49 SET PSOCOM=$GET(^UTILITY($JOB,"W",1,PSOY,0))
+50 ;
+51 ; Looping through the array in reverse order means PSOCNT=1
+52 ; will be the last comment to display. If the last line of the
+53 ; last comment is being displayed, set PSOLAST=1 to underline
+54 ; the comment on the screen.
+55 ;
+56 IF '$DATA(^UTILITY($JOB,"W",1,PSOY+1))
IF PSOCNT=1
SET PSOLAST=1
+57 ;
+58 ; Use SETLN^PSOREJP1 to add line to ^TMP array to be displayed to screen.
+59 ;
+60 DO SETLN^PSOREJP1($SELECT(PSOY=1:"- ",1:" ")_PSOCOM,0,PSOLAST,1)
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;
+62 KILL ^UTILITY($JOB,"W")
+63 ;
+64 QUIT
+65 ;
ADDCOM ; - Add comment worklist action
+1 NEW DIR,PSO55,PSCOM,PSOCOMTYPE
+2 DO FULL^VALM1
+3 ;
+4 SET DIR(0)="S^R:Reject;P:Patient Billing"
+5 SET DIR("A")="Comment Type"
+6 SET DIR("?",1)="The Reject Comment only displays for the specific reject."
+7 SET DIR("?")="The Patient Billing Comment displays on all rejects for the patient."
+8 DO ^DIR
+9 IF $DATA(DIRUT)
SET VALMBCK="R"
QUIT
+10 SET PSOCOMTYPE=Y
+11 ;
+12 IF PSOCOMTYPE="P"
IF '$DATA(^XUSEC("PSO EPHARMACY SITE MANAGER",DUZ))
Begin DoDot:1
+13 WRITE !,"Patient Billing Comments require Pharmacy Key (PSO EPHARMACY SITE MANAGER)"
+14 DO WAIT^VALM1
End DoDot:1
SET VALMBCK="R"
QUIT
+15 ;
+16 SET PSCOM=$$COMMENT("Comment: ",150)
+17 ;
+18 ; Save Reject Type Comment
+19 IF PSOCOMTYPE="R"
IF $LENGTH(PSCOM)>0
IF PSCOM'["^"
Begin DoDot:1
+20 ;save the comment
DO SAVECOM(RX,REJ,PSCOM)
+21 ;update screen
DO INIT^PSOREJP1
End DoDot:1
+22 ; Save Patient Billing Type Comment
+23 IF PSOCOMTYPE="P"
IF $LENGTH(PSCOM)>0
IF PSCOM'["^"
Begin DoDot:1
+24 SET PSO55=$$GET1^DIQ(52,RX,2,"I")
+25 DO ADDPC^PSOPTC0(PSCOM,PSO55)
+26 DO INIT^PSOREJP1
End DoDot:1
+27 SET VALMBCK="R"
+28 QUIT
+29 ;
+30 ;Enter a comment
+31 ;PSOTR -prompt string
+32 ;PSMLEN -maxlen
+33 ;returns:
+34 ; "^" - if user chose to quit
+35 ; "" - nothing entered or input has been discarded
+36 ; otherwise - comment's text
+1 NEW DIR,DTOUT,DUOUT,PSQ
+2 IF '$DATA(PSOTR)
SET PSOTR="Comment "
+3 IF '$DATA(PSMLEN)
SET PSMLEN=150
+4 SET DIR(0)="FA^1:150"
+5 SET DIR("A")=PSOTR
+6 SET DIR("?")="Enter a free text comment up to 150 characters long."
+7 SET PSQ=0
+8 FOR
Begin DoDot:1
+9 WRITE !
DO ^DIR
+10 IF $DATA(DUOUT)!($DATA(DTOUT))
SET PSQ=-1
QUIT
+11 IF $LENGTH(Y)'>PSMLEN
SET PSQ=1
QUIT
+12 WRITE !!,"Enter a free text comment up to 150 characters long.",!
+13 SET DIR("B")=$EXTRACT(Y,1,PSMLEN)
End DoDot:1
if +PSQ'=0
QUIT
+14 if PSQ<0
QUIT "^"
+15 if $LENGTH(Y)=0
QUIT ""
+16 SET PSQ=$$YESNO("Confirm","YES")
+17 IF PSQ=-1
QUIT "^"
+18 IF PSQ=0
QUIT ""
+19 QUIT Y
+20 ;
+21 ; Ask
+22 ; Input:
+23 ; PSQSTR - question
+24 ; PSDFL - default answer
+25 ; Output:
+26 ; 1 YES
+27 ; 0 NO
+28 ; -1 if cancelled
YESNO(PSQSTR,PSDFL) ; Default - YES
+1 NEW DIR,Y,DUOUT
+2 SET DIR(0)="Y"
+3 SET DIR("A")=PSQSTR
+4 if $LENGTH($GET(PSDFL))
SET DIR("B")=PSDFL
+5 WRITE !
DO ^DIR
+6 QUIT $SELECT($GET(DUOUT)!$GET(DUOUT)!(Y="^"):-1,1:Y)
+7 ;
+8 ;Save comment
SAVECOM(PSRXIEN,PSREJIEN,PSCOMNT,DATETIME,USER) ;
+1 NEW PSREC,PSDA,PSERR
+2 IF '$GET(DATETIME)
DO NOW^%DTC
SET DATETIME=%
+3 IF '$GET(USER)
SET USER=DUZ
+4 DO INSITEM(52.2551,PSRXIEN,PSREJIEN,DATETIME)
+5 SET PSREC=$ORDER(^PSRX(PSRXIEN,"REJ",PSREJIEN,"COM","B",DATETIME,0))
+6 IF PSREC>0
Begin DoDot:1
+7 SET PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",1)=USER
+8 SET PSDA(52.2551,PSREC_","_PSREJIEN_","_PSRXIEN_",",2)=$GET(PSCOMNT)
+9 DO FILE^DIE("","PSDA","PSERR")
End DoDot:1
+10 QUIT
+11 ;
+12 ;/**
+13 ;PSSFILE - subfile# (52.2551) for comment
+14 ;PSIEN - ien for file in which the new subfile entry will be inserted
+15 ;PSVAL01 - .01 value for the new entry
INSITEM(PSSFILE,PSIEN0,PSIEN1,PSVAL01) ;*/
+1 NEW PSSSI,PSIENS,PSFDA,PSER
+2 SET PSIENS="+1,"_PSIEN1_","_PSIEN0_","
+3 SET PSFDA(PSSFILE,PSIENS,.01)=PSVAL01
+4 DO UPDATE^DIE("","PSFDA","PSSSI","PSER")
+5 IF $DATA(PSER)
DO BMES^XPDUTL(PSER("DIERR",1,"TEXT",1))
+6 QUIT
+7 ;
PRINT(RX,RFL) ; Print Label for specific Rx/Fill
+1 IF '$GET(RX)
QUIT
+2 IF $GET(RFL)=""
QUIT
+3 ;
+4 ; Some of these variables are used by LBL^PSOLSET but they are newed here
+5 NEW PPL,PSOSITE,PSOPAR,PSOSYS,PSOBARS,PSOBAR0,PSOBAR1,PSOIOS,PSOBFLAG,PSOCLBL
+6 NEW PSOQUIT,PSOPIOST,PSOLTEST,PSOTLBL,PSORXT
+7 NEW DFN,PDUZ,RXFL,REPRINT,REJLBL,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+8 NEW %ZIS,IOP,POP,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTDTH,VAR
+9 ;
+10 ; Set the default label printer. We need to new it so we don't change the value that was
+11 ; set by PSOLSET when the user first logged into OP so need to do a bit of work to new it and
+12 ; reset it before the call to LBL^PSOLSET.
+13 IF $GET(PSOLAP)]""
SET PSOTLBL=PSOLAP
NEW PSOLAP
SET PSOLAP=PSOTLBL
SET PSOCLBL=1
+14 IF '$TEST
NEW PSOLAP
SET PSOCLBL=""
+15 ;
+16 ; Check if a label has already been printed and set REPRINT flag.
+17 SET REJLBL=0
FOR
SET REJLBL=$ORDER(^PSRX(RX,"L",REJLBL))
if 'REJLBL
QUIT
IF +$$GET1^DIQ(52.032,REJLBL_","_RX,1,"I")=RFL
SET REPRINT=1
QUIT
+18 ;
+19 ; Define required variables
+20 SET PSOSITE=+$$RXSITE^PSOBPSUT(RX,RFL)
SET PSOPAR=$GET(^PS(59,PSOSITE,1))
+21 SET DFN=$$GET1^DIQ(52,RX,2,"I")
SET PDUZ=DUZ
SET PSOSYS=$GET(^PS(59.7,1,40.1))
+22 SET PPL=RX
IF RFL
SET RXFL(RX)=RFL
+23 ;
+24 ; Get label print device and check alignment
+25 WRITE !
SET PSOBFLAG=1
DO LBL^PSOLSET
IF $GET(PSOQUIT)
QUIT
+26 IF $GET(PSOLAP)=""
WRITE $CHAR(7),!!,"No printer defined"
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
QUIT
+27 ;
+28 ; Call %ZIS to get device characteristics w/o reopening the printer.
+29 ; We need to do this to check if queuing is forced for this device
+30 ; Not checking the POP variable. If we don't get the device here, we will fall through to the
+31 ; foreground process and try again
+32 SET IOP=PSOLAP
SET %ZIS="QN"
DO ^%ZIS
+33 ;
+34 ; If background printer, queue the job
+35 IF $DATA(IO("Q"))
Begin DoDot:1
+36 SET ZTRTN="DQ^PSOLBL"
SET ZTDTH=$HOROLOG
SET ZTIO=PSOLAP
+37 FOR VAR="PSOSYS","DFN","PSOPAR","PDUZ","PCOMX","PSOLAP","PPL","PSOSITE","RXY","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP","REPRINT"
if $DATA(@VAR)
SET ZTSAVE(VAR)=""
+38 SET ZTSAVE("PSORX(")=""
SET ZTSAVE("RXRP(")=""
SET ZTSAVE("RXPR(")=""
SET ZTSAVE("RXRS(")=""
SET ZTSAVE("RXFL(")=""
SET ZTSAVE("PCOMH(")=""
+39 SET ZTDESC="OUTPATIENT PHARMACY REJECT WORKLIST LABEL PRINT"
+40 DO ^%ZISC
DO ^%ZTLOAD
+41 WRITE !!,"Label ",$SELECT('$DATA(ZTSK):"NOT ",1:""),"queued to print",!
IF '$DATA(ZTSK)
WRITE $CHAR(7)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
End DoDot:1
QUIT
+42 ;
+43 ; If we gotten this far, open the device and print the label in the foreground
+44 ; We also need to preserve the PSORX array, which gets killed by DQ^PSOLBL
+45 KILL %ZIS
SET IOP=PSOLAP
DO ^%ZIS
+46 IF POP
DO ^%ZISC
WRITE $CHAR(7),!!,"Printer is busy - NO label printed"
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
QUIT
+47 KILL PSORXT
MERGE PSORXT=PSORX
+48 DO DQ^PSOLBL
DO ^%ZISC
+49 KILL PSORX
MERGE PSORX=PSORXT
+50 QUIT
+51 ;
RXINFO(RX,FILL,LINE,REJ) ; Returns header displayable Rx Information
+1 NEW TXT,RXINFO,LBL,CMOP,DRG,PSOET
+2 IF LINE=1
Begin DoDot:1
+3 ; Get Date of Service from BPS CLAIM field 401 - PSO*7*421
NEW RXDOS
DO GETDAT^BPSBUTL(RX,FILL,,.RXDOS)
+4 SET RXINFO="Rx# : "_$$GET1^DIQ(52,RX,.01)_"/"_FILL
+5 ;cnf, PSO*7*358, add PSOET logic for TRICARE/CHAMPVA non-billable
+6 SET PSOET=$$PSOET(RX,FILL)
+7 SET $EXTRACT(RXINFO,27)="ECME#: "_$SELECT(PSOET:"",1:$$ECMENUM^PSOBPSU2(RX,FILL))
+8 ; Use DOS from BPS Claims field 401 - PSO*7*421
SET $EXTRACT(RXINFO,49)="Date of Service: "_$SELECT(PSOET:"",1:$$FMTE^XLFDT(RXDOS))
End DoDot:1
+9 IF LINE=2
Begin DoDot:1
+10 SET DRG=$$GET1^DIQ(52,RX,6,"I")
SET CMOP=$SELECT($DATA(^PSDRUG("AQ",DRG)):1,1:0)
+11 SET RXINFO=$SELECT(CMOP:"CMOP ",1:"")_"Drug"
SET $EXTRACT(RXINFO,10)=": "_$EXTRACT($$GET1^DIQ(52,RX,6),1,43)
+12 SET $EXTRACT(RXINFO,56)="NDC Code: "_$$GETNDC^PSONDCUT(RX,FILL)
End DoDot:1
+13 QUIT $GET(RXINFO)
+14 ;
FILL ;Fill payable TRICARE or CHAMPVA Rx
+1 NEW COM,I,OPNREJ,OPNREJ2,OPNREJ3,DCSTAT,PSOREL
+2 ;cnf, PSO*7*358, add line
if '$GET(PSOTRIC)
SET PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
+3 ;cnf, PSO*7*358, don't allow option if TRICARE/CHAMPVA and released, PSOREL is set to the release date
+4 SET PSOREL=0
IF PSOTRIC
Begin DoDot:1
+5 IF 'FILL
SET PSOREL=+$$GET1^DIQ(52,RX,31,"I")
+6 IF FILL
SET PSOREL=+$$GET1^DIQ(52.1,FILL_","_RX,17,"I")
End DoDot:1
+7 IF PSOREL
SET VALMSG="Released Rxs may not be filled."
SET VALMBCK="R"
QUIT
+8 ;cnf, PSO*7*358, don't allow option if prescription has been discontinued
+9 ; 12 - DISCONTINUED
+10 ; 14 - DISCONTINUED BY PROVIDER
+11 ; 15 - DISCONTINUED (EDIT)
+12 SET DCSTAT=$$GET1^DIQ(52,RX,100,"I")
+13 IF "/12/14/15/"[("/"_DCSTAT_"/")
SET VALMSG="Discontinued Rxs may not be filled."
SET VALMBCK="R"
QUIT
+14 DO FULL^VALM1
+15 IF $$CLOSED^PSOREJP1(RX,REJ)
Begin DoDot:1
+16 SET VALMSG="This Reject is marked resolved!"
SET VALMBCK="R"
End DoDot:1
QUIT
+17 ;cnf, PSO*7*358
+18 SET COM=""
+19 IF 'PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE")
SET VALMSG="Only Rxs with an E PAYABLE status may be filled."
SET VALMBCK="R"
QUIT
+20 ;cnf, PSO*7*358
IF PSOTRIC&($$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE")
DO FILLTR
IF $LENGTH($GET(VALMSG)_$GET(VALMBCK))
QUIT
+21 ;cnf, PSO*7*358, add condition
if COM=""
SET COM="AUTOMATICALLY CLOSED"
+22 SET (OPNREJ,OPNREJ2,OPNREJ3)=""
+23 SET OPNREJ2=0
FOR
SET OPNREJ2=$ORDER(^PSRX(RX,"REJ",OPNREJ2))
if OPNREJ2=""!(OPNREJ2'?1N.N)
QUIT
SET OPNREJ=OPNREJ_","_OPNREJ2
+24 SET OPNREJ=$EXTRACT(OPNREJ,2,999)
SET OPNREJ2=""
+25 WRITE !?20,"[Closing all rejections for prescription "_$$GET1^DIQ(52,RX,".01")_":"
+26 FOR I=1:1
SET OPNREJ2=$PIECE(OPNREJ,",",I)
if OPNREJ2=""
QUIT
Begin DoDot:1
+27 SET OPNREJ3=""
SET OPNREJ3=$$GET1^DIQ(52.25,OPNREJ2_","_RX,".01")
+28 WRITE !?25,OPNREJ3_" - "_$$GET1^DIQ(9002313.93,OPNREJ3,".02")_"..."
+29 ; pso*7*421 Use 12th param to ignore
DO CLOSE^PSOREJUT(RX,FILL,OPNREJ2,DUZ,6,COM,"","","","","",1)
WRITE "OK]",!,$CHAR(7)
HANG 1
End DoDot:1
+30 IF $$PTLBL^PSOREJP2(RX,FILL)
DO PRINT(RX,FILL)
+31 ;cnf, PSO*7*358, remove S VALMBCK="R" so user goes back to selection list
SET CHANGE=1
+32 QUIT
+33 ;
PSOCOB(RX,FILL,REJ) ; Returns RXCOB indicator for Worklist
+1 NEW DATA1
+2 DO GET^PSOREJU2(RX,FILL,.DATA1,REJ,1)
+3 IF $GET(DATA1(REJ,"COB"))="PRIMARY"
QUIT 1
+4 IF $GET(DATA1(REJ,"COB"))=""
QUIT 1
+5 QUIT 2
+6 ;
DC ;Discontinue TRICARE Rx
+1 NEW ACTION
SET ACTION="D"
+2 DO FULL^VALM1
+3 SET ACTION=$$DC^PSOREJU1(RX,ACTION)
+4 IF ACTION="Q"!(ACTION="^")
SET VALMSG="NO ACTION TAKEN."
SET VALMBCK="R"
QUIT
+5 SET CHANGE=1
+6 QUIT
+7 ;
FILLTR ;TRICARE/CHAMPVA specific logic ;cnf, PSO*7*358
+1 ;COM is not new'd so the variable can be used in FILL tag
+2 NEW CONT,PSOETEC,PSQSTR
+3 ;
FILLTR2 ;Use for looping if user enters ^ in required comment field ;cnf, PSO*7*358
+1 ;
+2 ;if TRICARE/CHAMPVA, not payable, and no security key, quit
+3 ;reference to ^XUSEC( supported by IA 10076
+4 IF '$DATA(^XUSEC("PSO TRICARE/CHAMPVA",DUZ))
SET VALMSG="Action Requires <PSO TRICARE/CHAMPVA> security key"
SET VALMBCK="R"
QUIT
+5 ;
+6 ;if TRICARE/CHAMPVA, not payable, and user has security key, prompt to continue or not
+7 SET PSQSTR="You are bypassing claims processing. Do you wish to continue"
+8 SET CONT=$$YESNO(PSQSTR,"No")
+9 IF (CONT=-1)!('CONT)
SET VALMSG="NO ACTION TAKEN."
SET VALMBCK="R"
QUIT
+10 ;
+11 ;check for valid electronic signature
+12 ;quit if no valid electronic signature
IF '$$SIG^PSOREJU1()
SET VALMBCK="R"
QUIT
+13 ;
+14 ;prompt user for required TRICARE/CHAMPVA Justification
+15 ;loop back to "continue?" question if ^ entry
SET COM=$$TCOM(RX,FILL)
if COM="^"
GOTO FILLTR2
+16 ;
+17 ;audit log
+18 SET PSOETEC=$$PSOETEC^PSOREJP5(RX,FILL)
+19 DO AUDIT^PSOTRI(RX,FILL,,COM,$SELECT(PSOETEC:"N",1:"R"),$SELECT($GET(PSOTRIC)=1:"T",$GET(PSOTRIC)=2:"C",1:""))
+20 QUIT
+21 ;
TCOM(RX,RFL) ; - Ask for TRICARE or CHAMPVA Justification
+1 NEW COM,DIR,DIRUT,X
+2 WRITE !
SET DIR(0)="F^3:100"
SET DIR("A")=$$ELIGDISP^PSOREJP1(RX,RFL)_" Justification"
DO ^DIR
+3 SET COM=X
IF $DATA(DIRUT)
SET COM="^"
+4 QUIT COM
+5 ;
PSOET(RX,FILL) ; Returns flag for TRICARE or CHAMPVA non-billable and no claim submitted
+1 ; Return 1 if rejection code is eT or eC (pseudo-reject code)
+2 ; 0 otherwise
+3 ;
+4 IF '$GET(RX)
QUIT 0
+5 NEW X,TRIREJCD
+6 SET X=0
+7 SET TRIREJCD=$TEXT(TRIREJCD+1)
SET TRIREJCD=$PIECE(TRIREJCD,";;",2)
+8 ; PSO*7*421 - Pass indicator to ignore ECME status
SET X=$$FIND^PSOREJUT(RX,$GET(FILL),,TRIREJCD,1)
+9 QUIT X
+10 ;
TRIREJCD ;TRICARE or CHAMPVA Reject Code, non-billable Rx ;cnf, PSO*7*358
+1 ;;eT,eC;;TRICARE or CHAMPVA pseudo reject codes referenced in ^PSOREJP3, ^PSOREJU4
+2 QUIT
+3 ;
SEND(OVRCOD,CLA,PA,PSOET) ; - Sends Claim to ECME and closes Reject
+1 ; Input: OVRCOD - Up to three ~-pieces, and each populated would be
+2 ; Reason for Service Code ^ Prof Srvc Cd ^ Result of Srvc Cd
+3 ; CLA - Submission Clarification Code #1 ~ SCC #2 ~ SCC #3
+4 ; PA - Prior Auth Type ^ Prior Auth Number
+5 ; PSOET - 1 if eT/eC pseudo-reject on claim
+6 NEW ALTXT,COM,DIR,PSO59,PSOCOB,PSOETEC,PSOPLAN,PSORTYPE,RESP,SMA
+7 NEW DIWF,DIWL,DIWR,X
+8 SET DIR(0)="Y"
SET DIR("A")=" Confirm"
SET DIR("B")="YES"
+9 SET DIR("A",1)=" When you confirm, a new claim will be submitted for"
+10 SET DIR("A",2)=" the prescription and this REJECT will be marked"
+11 SET DIR("A",3)=" resolved."
+12 SET DIR("A",4)=" "
+13 WRITE !
DO ^DIR
KILL DIR
IF $GET(Y)=0!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+14 SET SMA=0
IF $GET(OVRCOD)]""
IF $GET(CLA)]""
IF $GET(PA)]""
SET SMA=1
+15 SET ALTXT=""
+16 IF 'SMA
Begin DoDot:1
+17 SET ALTXT="REJECT WORKLIST"
+18 if $GET(OVRCOD)'=""
SET ALTXT=ALTXT_"-DUR OVERRIDE CODES("_$TRANSLATE(OVRCOD,"^","/")_")"
+19 if $GET(CLA)]""
SET ALTXT=ALTXT_"-(CLARIF. CODE="_CLA_")"
+20 if $GET(PA)]""
SET ALTXT=ALTXT_"-(PRIOR AUTH.="_$TRANSLATE(PA,"^","/")_")"
End DoDot:1
+21 ;
+22 SET PSOCOB=$$PSOCOB^PSOREJP3(RX,FILL,REJ)
+23 SET PSO59=$$IEN59^BPSOSRX(RX,FILL,PSOCOB)
+24 ; IA 6939
SET PSOPLAN=$$GETPL59^BPSPRRX5(PSO59)
+25 ; IA 6939
SET PSORTYPE=$$GETRTP59^BPSPRRX5(PSO59)
+26 ; Check for Tricare/Champva Non-Billable eT,eC pseudo reject set PSOETEC=1
+27 SET PSOETEC=""
+28 IF ($DATA(^PSRX(RX,"REJ","B","eT")))!($DATA(^PSRX(RX,"REJ","B","eC")))
SET PSOETEC=1
+29 ;
+30 DO ECMESND^PSOBPSU1(RX,FILL,,$SELECT($GET(PSOET):"RSNB",1:"ED"),$$GETNDC^PSONDCUT(RX,FILL),,,$GET(OVRCOD),,.RESP,,ALTXT,$GET(CLA),$GET(PA),PSOCOB,,PSOPLAN,PSORTYPE)
+31 ;If PSOETEC=1 RESP will exist because its a Non-Billable Rx, do not Quit continue processing
+32 IF PSOETEC'=1
IF $GET(RESP)
Begin DoDot:1
+33 WRITE !!?10,"Claim could not be submitted. Please try again later!"
+34 IF $PIECE(RESP,"^",2)=""
SET X="Reason: UNKNOWN"
+35 IF '$TEST
SET X="Reason: "_$PIECE(RESP,"^",2)
+36 SET DIWF="W"
+37 SET DIWL=11
+38 SET DIWR=75
+39 DO ^DIWP
+40 DO ^DIWW
+41 WRITE $CHAR(7)
+42 HANG 2
End DoDot:1
QUIT
+43 ;
+44 ; Get the ePharmacy Response Pause and hang for that amount of time (default is 2 if not set)
+45 NEW PAUSE,IEN5286
+46 IF $GET(PSOSITE)=""
NEW PSOSITE
SET PSOSITE=$$RXSITE^PSOBPSUT(RX,FILL)
+47 SET IEN5286=$ORDER(^PS(52.86,"B",+PSOSITE,""))
+48 SET PAUSE=$$GET1^DIQ(52.86,IEN5286_",",6)
+49 IF PAUSE=""
SET PAUSE=2
+50 IF PAUSE
HANG PAUSE
+51 ;
+52 IF $$PTLBL^PSOREJP2(RX,FILL)
DO PRINT(RX,FILL)
+53 NEW PSOTRIC
SET PSOTRIC=""
SET PSOTRIC=$$TRIC^PSOREJP1(RX,FILL,PSOTRIC)
+54 IF $$GET1^DIQ(52,RX,100,"I")=5&(PSOTRIC)
Begin DoDot:1
+55 if $$STATUS^PSOBPSUT(RX,FILL)'["PAYABLE"
QUIT
+56 NEW XXX
SET XXX=""
+57 WRITE !,"This prescription can be pulled early from suspense or the label will print"
+58 WRITE !,"when PRINT FROM SUSPENSE occurs.",!
+59 READ !,"Press enter to continue... ",XXX:60
End DoDot:1
+60 IF $DATA(PSOSTFLT)
IF PSOSTFLT'="B"
SET CHANGE=1
+61 QUIT
