- 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 Jan 18, 2025@03:34:42 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