Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOREJP3

PSOREJP3.m

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