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

PSOREJU1.m

Go to the documentation of this file.
  1. PSOREJU1 ;BIRM/MFR - BPS (ECME) - Clinical Rejects Utilities (1) ;10/15/04
  1. ;;7.0;OUTPATIENT PHARMACY;**148,247,260,287,289,358,359,385,403,421,482,562,702**;DEC 1997;Build 14
  1. ; Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE in ICR #4712
  1. ; Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE in ICR #4713
  1. ; Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE in ICR #4714
  1. ; Reference to File 9002313.25 - BPS NCPDP SUBMISSION CLARIFICATION CODE in ICR #5064
  1. ; Reference to File 200 - NEW PERSON in ICR #10060
  1. ; Reference to SIG^XUSESIG in ICR #10050
  1. ; Reference to AMT^BPSBUTL in ICR #4719
  1. ;
  1. ACTION(RX,REJ,OPTS,DEF,RRR) ;
  1. ; Input: (r) RX - Rx IEN (#52)
  1. ; (r) REJ - REJECT ID (IEN)
  1. ; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
  1. ; (o) DEF - Default Option ("O", "I" or "Q")
  1. ; (o) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due (Default: 0)
  1. ; If Flag = 0, there is no Reject Resolution Required reject code.
  1. ; Output: ACTION: "I^Comments" - Ignore Reject
  1. ; "O^COD1^COD2^COD3" - Override with the Override codes COD1(Prof.),COD2(Reason) and COD3(Result)
  1. ; "D" - Discontinue
  1. ; "Q" - Quit
  1. ; "^" - Up-arrow entered or timed out
  1. ;
  1. N ACTION,COM,OVR,X,DIR,DIRUT,Y
  1. ;
  1. I '$G(RX)!'$G(REJ) Q
  1. I '$G(PSONBILL) Q:'$D(^PSRX(RX,"REJ",REJ))
  1. ;
  1. ; Display reject information
  1. D DISPLAY^PSOREJU3(RX,REJ,,RRR)
  1. ;
  1. ASK ;
  1. K ACTION,DIR,DIRUT
  1. S DIR(0)="SO^",DIR("A")=""
  1. S:(OPTS["O") DIR(0)=DIR(0)_"O:(O)VERRIDE - RESUBMIT WITH OVERRIDE CODES;",DIR("A")=DIR("A")_"(O)verride,"
  1. S:(OPTS["I") DIR(0)=DIR(0)_"I:(I)GNORE - FILL Rx WITHOUT CLAIM SUBMISSION;",DIR("A")=DIR("A")_"(I)gnore,"
  1. S:(OPTS["D") DIR(0)=DIR(0)_"D:(D)iscontinue - DO NOT FILL PRESCRIPTION;",DIR("A")=DIR("A")_"(D)iscontinue,"
  1. S:(OPTS["Q") DIR(0)=DIR(0)_"Q:(Q)UIT - SEND TO WORKLIST (REQUIRES INTERVENTION);",DIR("A")=DIR("A")_"(Q)uit,"
  1. S $E(DIR(0),$L(DIR(0)))="",$E(DIR("A"),$L(DIR("A")))="",DIR("??")="^D HELP^PSOREJU2("""_OPTS_""")"
  1. S:$G(DEF)'="" DIR("B")=DEF
  1. D ^DIR
  1. I $D(DIRUT) W ! Q "Q"
  1. S ACTION=Y
  1. ;
  1. ; STOP/QUIT Action
  1. I ACTION="Q" Q ACTION
  1. ;
  1. ; IGNORE Action
  1. K DIR,DIRUT,X
  1. ;
  1. N PSOIT
  1. S PSOIT=""
  1. I ACTION="I" S PSOIT=$$IGNORE(RX,RFL)
  1. I $P(PSOIT,"^")=0 D G ASK
  1. . I $P(PSOIT,"^",2)'="" D
  1. . . W $C(7),!,"Gross Amount Due is $"_$P(PSOIT,"^",2)_". IGNORE requires EPHARMACY SITE MANAGER key.",!
  1. ;
  1. ; If TRICARE/CHAMPVA, require confirmation before ignoring.
  1. I PSOTRIC,ACTION="I",'$$CONT W $C(7),!," ACTION NOT TAKEN!",! H 1 G ASK
  1. ;
  1. I ACTION="I" S:'PSOTRIC COM=$$COM() S:PSOTRIC COM=$$TCOM^PSOREJP3(RX,RFL) G ASK:COM="^" G ASK:'$$SIG() S ACTION=ACTION_"^"_COM
  1. ;
  1. ; OVERRIDE Action
  1. I ACTION="O" D G ASK:OVR="^"
  1. . S OVR=$$OVR() S ACTION=ACTION_"^"_OVR
  1. ;
  1. DC1 ;Discontinue
  1. I ACTION="D" S ACTION=$$DC(RX,ACTION,1) I $D(DIRUT) S ACTION="D" D DISPLAY^PSOREJU3(RX,REJ) G ASK
  1. ;
  1. Q ACTION
  1. ;
  1. DC(RX,ACTION,DC1) ; Discontinue inside and outside call
  1. ; DC1 Indicates that DIRUT needs to be returned if applicable
  1. S DC1=+$G(DC1)
  1. N RXN,MSG,REA,DA,PSCAN,RXNUM
  1. S DA=RX,RXNUM=""
  1. ; Set PSOTRIC, if not already set. PSOTRIC is used by NOOR^PSOCAN4,
  1. ; which is called by COM^PSOCAN1.
  1. I '$D(PSOTRIC) N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RX)
  1. N VALMBCK,PS
  1. S VALMBCK="",PS="Discontinue"
  1. D YN^PSOCAN I VALMBCK="R" W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" S:DC1 DIRUT=1 Q ACTION
  1. N PKIR
  1. K DIR
  1. D COM^PSOCAN1 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION
  1. N PSOCANRD S PSOCANRD=$P(^PSRX(DA,0),"^",4)
  1. D REQ^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION
  1. S REA="C",RXNUM=$P(^PSRX(DA,0),"^")
  1. S MSG="Discontinued "_$S($G(PSOFDR):" from Reject Processing Screen",1:"")
  1. S PSCAN(RXNUM)=DA_"^C"
  1. D CAN^PSOCAN
  1. ;
  1. ; These two lines may not be needed. It seems premature to remove the
  1. ; RX from the label list when the Rx probably hasn't been added yet.
  1. ; In addition, PSORXL has code to remove discontinued RXs from the
  1. ; label list (using the ECME^PSORXL1 call).
  1. S PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,DA,100),ORN=1
  1. N PSOCKDC S PSOCKDC=1 D ECME^PSORXL1 I '$G(PPL) S PPL="" ;remove rx from label print
  1. Q ACTION
  1. ;
  1. CONT() ; Ask to continue for bypassing claims processing
  1. N DIR,DIRUT,Y
  1. S DIR(0)="Y",DIR("A")="You are bypassing claims processing. Do you wish to continue",DIR("B")="NO"
  1. D ^DIR
  1. I $D(DIRUT) S Y=0
  1. Q $G(Y)
  1. ;
  1. SIG() ; Get electronic signature
  1. N CODE,X,X1,Y
  1. S CODE=$P($G(^VA(200,DUZ,20)),U,4),Y=0 I '$L(CODE) D Q Y
  1. . W $C(7),!,"You do not have an electronic signature code."
  1. . W !,"Please contact your IRM office." H 2
  1. D SIG^XUSESIG S Y=(X1'="")
  1. Q Y
  1. ;
  1. COM() ; Ask for CLOSE comments
  1. K COM,DIR,DIRUT,X
  1. W ! S DIR(0)="F^3:100" S DIR("A")="Comments" D ^DIR
  1. S COM=X
  1. I $D(DIRUT) S COM="^"
  1. Q COM
  1. ;
  1. OVR() ; Ask for OVERRIDE codes
  1. ; Called by ASK above (Reject Notification Screen)
  1. N COD1,COD2,COD3,DIR,DIRUT W !
  1. S COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^"!(COD1="") Q "^"
  1. S COD2=$$OVRCOD(2) I COD2="^" Q COD2
  1. S COD3=$$OVRCOD(3) I COD3="^" Q COD3
  1. ;
  1. D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3)
  1. W !
  1. ;
  1. S DIR(0)="Y",DIR("A")=" Confirm? ",DIR("B")="YES"
  1. D ^DIR
  1. I $G(Y)=0!$D(DIRUT) Q "^"
  1. ;
  1. Q (COD1_"^"_COD2_"^"_COD3)
  1. ;
  1. OVRDSP(LST) ; Display the Override Codes
  1. N I W !
  1. F I=1:1:3 D
  1. . W !?5,$S(I=1:"Reason for Service Code : ",I=2:"Professional Service Code: ",1:"Result of Service Code : ")
  1. . W $E($$OVRX(I,$P(LST,"^",I)),1,48)
  1. Q
  1. ;
  1. CLA() ; Ask for up to 3 Clarification Codes
  1. ; Called by SMA^PSOREJP1 (SMA action) and CLA^PSOREJP1 (CLA action)
  1. N DIC,X,Y,PSOSCC,DTOUT,DUOUT,PSOQ,PSOI,I,DUP
  1. S DIC(0)="QEAM",DIC=9002313.25,PSOQ=0,PSOSCC=""
  1. S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
  1. F PSOI=1:1:3 Q:PSOQ S DIC("A")="Submission Clarification Code "_PSOI_": " D CLADIC
  1. Q $S(PSOQ=1:"^",1:PSOSCC)
  1. ;
  1. CLADIC ;
  1. ; DIC variables, PSOI, PSOSCC, and DUP newed and set by CLA
  1. D ^DIC
  1. I ($D(DUOUT))!($D(DTOUT)) S PSOQ=1 Q
  1. I Y=-1 S PSOQ=2 Q
  1. S DUP=0
  1. F I=1:1:PSOI I $P(PSOSCC,"~",I)=$P(Y,U,2) S DUP=1 Q
  1. I DUP=1 W " Duplicates not allowed",! G CLADIC
  1. S $P(PSOSCC,"~",PSOI)=$P(Y,U,2)
  1. Q
  1. ;
  1. HDLG(RX,RFL,CODES,FROM,OPTS,DEF) ; - REJECT Handling
  1. ;Input: (r) RX - Rx IEN (#52)
  1. ; (o) RFL - Refill # (Default: most recent)
  1. ; (r) CODES - List of REJECT CODES to be handled separated by commas (default is "79,88,943")
  1. ; (r) FROM - Same values as BWHERE param. in the EN^BPSNCPDP api
  1. ; (r) OPTS - Available options ("IOQ" for IGNORE/OVERRIDE/QUIT)
  1. ; (o) DEF - Default Option ("O", "I" or "Q")
  1. ;Output: ACTION - "O"-Override, "I"-Ignore,"Q"-Quit,"D"-Discontinue,"^"-Up-arrow entered
  1. ;
  1. N ACTION,NEWDATA,PSOTRIC,REJ,REJDATA,REJI,REJIEN,RESP,RESPI,RESPREJ,RRR
  1. S ACTION="",RRR=0
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. ;
  1. ; Get all open/unresolved rejects
  1. I '$$FIND^PSOREJUT(RX,RFL,.REJDATA) Q ACTION
  1. ;
  1. S PSOTRIC=$$TRIC^PSOREJP1(RX,RFL)
  1. ;
  1. ; Check for TRICARE/CHAMPVA open rejects
  1. I PSOTRIC D HDLGTC(.REJDATA,.OPTS,.DEF,.CODES,DUZ)
  1. ;
  1. ; In progress TRICARE/CHAMPVA Rx not allowed to be filled
  1. I PSOTRIC,$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS" D TRICCHK^PSOREJU3(RX,RFL,"",FROM) Q ACTION
  1. ;
  1. ; Check for VET with open RRR rejects, PSO*421
  1. I 'PSOTRIC D HDLGRRR(.REJDATA,.OPTS,.DEF,.RRR,.CODES)
  1. ;
  1. ; Check for open rejects that match CODES
  1. I '$$FIND^PSOREJUT(RX,RFL,.REJDATA,CODES) Q ACTION
  1. ;
  1. ; Get reject for last response, if multiple responses exist.
  1. S REJ=$O(REJDATA(""))
  1. S ACTION=$$ACTION(RX,REJ,OPTS,$G(DEF),RRR)
  1. ;
  1. ; Loop through each REJECT IEN and perform action
  1. S REJI="" F S REJI=$O(REJDATA(REJI)) Q:REJI="" D
  1. . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,6,$P(ACTION,"^",2),"","","","","",1) D AUDIT^PSOTRI(RX,RFL,,$P(ACTION,"^",2),$S($$PSOET^PSOREJP3(RX,RFL):"N",1:"R"),$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
  1. . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,1,,$P(ACTION,"^",2,4))
  1. . I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJI,DUZ,7,,$P(ACTION,"^",2))
  1. . Q
  1. . ;
  1. ; Resubmit claim if overriding
  1. I $P(ACTION,"^")="O" D
  1. . D ECMESND^PSOBPSU1(RX,RFL,,FROM,$$GETNDC^PSONDCUT(RX,RFL),,,$P(ACTION,"^",2,4),,.RESP)
  1. . I $G(RESP) D Q
  1. . . W !!?10,"Claim could not be submitted. Please try again later!"
  1. . . W !,?10,"Reason: ",$S($P(RESP,"^",2)="":"UNKNOWN",1:$P(RESP,"^",2)),$C(7)
  1. . . Q
  1. . ;
  1. . ; Get all open/unresolved rejects
  1. . K NEWDATA I $$FIND^PSOREJUT(RX,RFL,.NEWDATA) D I ACTION="Q"!(ACTION="^") Q
  1. . . ;
  1. . . ;For TRICARE/CHAMPVA, override OPTS and DEF if necessary
  1. . . I PSOTRIC D HDLGTC(.NEWDATA,.OPTS,.DEF,.CODES,DUZ)
  1. . . ;
  1. . . ;For Vet, override OPTS, DEF and set up RRR variable if necessary
  1. . . I 'PSOTRIC D HDLGRRR(.NEWDATA,.OPTS,.DEF,.RRR,.CODES)
  1. . . S OPTS=$TR(OPTS,"O") ; Remove the "O" to prevent the user from picking the override option repeatedly
  1. . . I '$$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODES) Q
  1. . . S ACTION=$$ACTION(RX,$O(NEWDATA("")),OPTS,$G(DEF),RRR) I ACTION="Q"!(ACTION="^") Q
  1. . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2),"","","","","",1) D AUDIT^PSOTRI(RX,RFL,,$P(ACTION,"^",2),"R",$S(PSOTRIC=1:"T",PSOTRIC=2:"C",1:""))
  1. . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",2,4))
  1. . . Q
  1. . Q
  1. ;
  1. Q ACTION
  1. ;
  1. HDLGRRR(RRRDATA,OPTS,DEF,RRR,CODES) ; Check for VET with open RRR rejects, new tag PSO*421
  1. ; Input: (r) RRRDATA - reject array returned by $$FIND
  1. ; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
  1. ; - possibly modified by subroutine
  1. ; (r) DEF - Default Option ("O", "I" or "Q")
  1. ; - possibly modified by subroutine
  1. ; (r) CODES - Open reject codes
  1. ; - modified by subroutine
  1. ; Output:(r) RRR - Reject Resolution Required information Flag(0/1)^Threshold Amt^Gross Amt Due
  1. ; - only return a value for RRR if not 79 or 88 or 943
  1. ;
  1. N REJIEN,EX7988,SAVECODES
  1. S SAVECODES=CODES
  1. S (REJIEN,CODES)="",RRR=0,EX7988=0
  1. ;
  1. ; Set CODES with all open RRR, 79, 88, and 943 reject codes for RX/Fill returned from $$FIND
  1. F S REJIEN=$O(RRRDATA(REJIEN)) Q:(REJIEN="")!EX7988 D
  1. . ;
  1. . ; Find RRR reject
  1. . I RRRDATA(REJIEN,"RRR FLAG")="YES" D Q
  1. . . S RRR=1_U_RRRDATA(REJIEN,"RRR THRESHOLD AMT")_U_RRRDATA(REJIEN,"RRR GROSS AMT DUE")
  1. . . S CODES=RRRDATA(REJIEN,"CODE")_","_CODES
  1. . . Q
  1. . ;
  1. . ; If reject code 79 or 88 or 943 is present, then don't set up RRR for display on reject notification screen (EX7988=1)
  1. . I "/79/88/943/"[("/"_RRRDATA(REJIEN,"CODE")_"/") S RRR=0,EX7988=1
  1. . Q
  1. ;
  1. I 'RRR S CODES=SAVECODES Q ;if not RRR, don't override CODES
  1. ;
  1. ; Strip the last comma off CODES
  1. I $E(CODES,$L(CODES))="," S CODES=$E(CODES,1,$L(CODES)-1)
  1. ;
  1. ; Set action prompt.
  1. S OPTS="IQ",DEF="Q"
  1. Q
  1. ;
  1. HDLGTC(REJDATA,OPTS,DEF,CODES,DUZ) ; Check for TRICARE/CHAMPVA open rejects
  1. ; Input: (r) REJDATA - reject array returned by $$FIND
  1. ; (r) OPTS - Available options ("QIDO" for QUIT/IGNORE/DISCONTINUE/OVERRIDE)
  1. ; - possibly modified by subroutine
  1. ; (r) DEF - Default Option ("O", "I" or "Q")
  1. ; - possibly modified by subroutine
  1. ; (r) CODES - Open reject codes
  1. ; - modified by subroutine
  1. ; (r) DUZ - Internal IEN of user
  1. N REJIEN
  1. S (REJIEN,CODES)=""
  1. ;
  1. ; Set CODES with all open reject codes for RX/Fill returned from $$FIND
  1. F S REJIEN=$O(REJDATA(REJIEN)) Q:REJIEN="" S CODES=REJDATA(REJIEN,"CODE")_","_CODES
  1. ;
  1. ; Strip the last comma off CODES
  1. I $E(CODES,$L(CODES))="," S CODES=$E(CODES,1,$L(CODES)-1)
  1. ;
  1. ; Set action prompt.
  1. S DEF="Q"
  1. S OPTS="DQ"
  1. I (","_CODES_",")[(",79,") S OPTS="ODQ"
  1. I (","_CODES_",")[(",88,") S OPTS="ODQ"
  1. I (","_CODES_",")[(",943,") S OPTS="ODQ"
  1. ;
  1. ; Include the Ignore action prompt if user holds key.
  1. I $D(^XUSEC("PSO TRICARE/CHAMPVA",DUZ)) S OPTS=OPTS_"I"
  1. Q
  1. ;
  1. OVRX(TYPE,CODE) ; Returns the extended code/description of the NCPDP DUR override codes
  1. ; Input: (r) TYPE - 1 (REASON FOR SERVICE), 2 (PROFESSIONAL SERVICE) or 3 (RESULT OF SERVICE)
  1. ; (r) CODE - Table IEN
  1. ; Output: "CODE - DESCRIPTION"
  1. N FILE,DIC,X,Y
  1. S FILE=9002313+$S(TYPE=1:.23,TYPE=2:.21,1:.22)
  1. S DIC=FILE,X=CODE D ^DIC
  1. I TYPE Q CODE_" - "_$$GET1^DIQ(FILE,+Y,1)
  1. Q ""
  1. ;
  1. ;
  1. OVRCOD(TYPE,VALUE) ; Prompt for NCPDP Override Codes
  1. ; Called by OVR above (reject notification screen), OVR^PSOREJP1 (OVR action)
  1. N DIC,DTOUT,DUOUT,FILE,PRPT,X,Y
  1. I TYPE=1 S FILE=9002313.23,PRPT="Reason for Service Code : "
  1. I TYPE=2 S FILE=9002313.21,PRPT="Professional Service Code: "
  1. I TYPE=3 S FILE=9002313.22,PRPT="Result of Service Code : "
  1. S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT
  1. I $G(VALUE)'="" S DIC("B")=VALUE
  1. S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
  1. D ^DIC
  1. I $D(DTOUT)!$D(DUOUT) Q "^"
  1. ; At second and third prompts of the set, user entering no data is like exiting the option
  1. I TYPE'=1,Y<0 Q "^"
  1. Q $P(Y,"^",2)
  1. ;
  1. OVRCOD1(VALUE,NUM) ; Prompt for Reason for Service Code
  1. ; Called by SMAOVR (SMA action) only
  1. N DIR,DTOUT,DTOUT,DIRUT,DIROUT,KFLAG,X,Y
  1. S DIR(0)="P^9002313.23:AOEMZ"
  1. S DIR("A")="Reason for Service Code "_NUM_" "
  1. S DIR("B")=VALUE
  1. S DIR("PRE")="I X=""@"" S X=""^"",KFLAG=1"
  1. S KFLAG=0
  1. S DIR("S")="I $P($G(^(0)),""^"",3)'=1"
  1. D ^DIR Q:KFLAG "@"
  1. I $D(DIRUT)!$D(DIROUT) Q "^"
  1. Q $P(Y,"^",2)
  1. ;
  1. OVRCOD2(TYPE,VALUE,NUM) ; Prompt for NCPDP Override Codes
  1. ; Called by SMAOVR (SMA action) only
  1. N DIC,DTOUT,DUOUT,FILE,PRPT,X,Y
  1. I TYPE=1 S FILE=9002313.23,PRPT="Reason for Service Code "_NUM_" : "
  1. I TYPE=2 S FILE=9002313.21,PRPT="Professional Service Code "_NUM_": "
  1. I TYPE=3 S FILE=9002313.22,PRPT="Result of Service Code "_NUM_" : "
  1. S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT
  1. I $G(VALUE)'="" S DIC("B")=VALUE
  1. S DIC("S")="I $P($G(^(0)),""^"",3)'=1"
  1. D ^DIC
  1. I $D(DTOUT)!$D(DUOUT) Q "^"
  1. ; At second and third prompts of the set, user entering no data is like exiting the option
  1. I TYPE'=1,Y<0 Q "^"
  1. Q $P(Y,"^",2)
  1. ;
  1. SEL(FIELD,FILE,ARRAY,DEFAULT) ; Provides field selection (one, multiple or ALL)
  1. N DIC,DTOUT,DUOUT,QT,Y,X
  1. W !!,"You may select a single or multiple "_FIELD_"S,"
  1. W !,"or enter ^ALL to select all "_FIELD_"S.",!
  1. K ARRAY S DIC=FILE,DIC(0)="QEZAM",DIC("A")=FIELD_": "
  1. I $G(DEFAULT)'="" S DIC("B")=DEFAULT
  1. F D ^DIC Q:X="" D Q:$G(QT)
  1. . I $$UP^XLFSTR(X)="^ALL" K ARRAY S ARRAY="ALL",QT=1 Q
  1. . I $D(DTOUT)!$D(DUOUT) K ARRAY S ARRAY="^",QT=1 Q
  1. . W " ",$P(Y,"^",2),$S($D(ARRAY(+Y)):" (already selected)",1:"")
  1. . W ! S ARRAY(+Y)="",DIC("A")="ANOTHER ONE: " K DIC("B")
  1. I '$D(ARRAY) S ARRAY="^"
  1. Q
  1. ;
  1. LMREJ(RX,RFL,MSG,BCK) ; Used by ListManager hidden actions to detect unresolved 3rd Party Rejects
  1. ;Input: (r) RX - Rx IEN (#52)
  1. ; (o) RFL - Refill # (Default: most recent)
  1. ;Output: (o) MSG - Usually this will be used to set VALMSG variable, which should be passed in by ref.
  1. ; (o) BCK - This will be used to set VALMBCK variable, which should be passed in by ref.
  1. ;
  1. I '$D(^PSRX(+RX)) Q 0
  1. I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1. I $$FIND^PSOREJUT(RX,RFL) D Q 1
  1. . S MSG="NOT ALLOWED! Rx has OPEN 3rd Party Payer Reject.",BCK="R" W $C(7),$C(7)
  1. Q 0
  1. ;
  1. DUP(RX,RSP,CLOSED) ; Checks if REJECT has already been logged in the PRESCRIPTION file
  1. ; Input: (r) RX - Rx IEN (#52)
  1. ; (o) RSP - Response IEN
  1. ; (o) CLOSED - If CLOSED=1 and Reject is closed, then do not count as duplicate
  1. ; Output: DUP - 1: Already logged (duplicate)
  1. ; 0: Not yet logged on PRESCRIPTION file
  1. N DUP,IDX
  1. I $G(CLOSED)="" S CLOSED=0
  1. S (DUP,IDX)=0
  1. F S IDX=$O(^PSRX(RX,"REJ",IDX)) Q:'IDX D Q:DUP
  1. . I +RSP=+$$GET1^DIQ(52.25,IDX_","_RX,16,"I") S DUP=1
  1. . I CLOSED=1,+$$GET1^DIQ(52.25,IDX_","_RX,9,"I")=1 S DUP=0
  1. Q DUP
  1. ;
  1. OTH(CODE,LST) ; Removes the current Reject code from the list
  1. ; Input: (r) CODE - Current Reject Code (79 or 88 or 943)
  1. ; (o) LST - List of all Reject codes with response (comma separated)
  1. ; Output: OTH - List of OTHER Reject codes (w/out 79 or 88 or 943)
  1. ;
  1. N I,OTH
  1. F I=1:1:$L(LST,",") D
  1. . I $P(LST,",",I)]"",$P(LST,",",I)'=CODE S OTH=$G(OTH)_","_$P(LST,",",I)
  1. S $E(OTH)=""
  1. Q OTH
  1. ;
  1. DAT(DAT) ; External Date
  1. S X=$$HL7TFM^XLFDT(DAT) I X<0 Q ""
  1. Q X
  1. ;
  1. CLEAN(STR) ; Remove blanks from the end of a string and replaces ";" with ","
  1. N LEN F LEN=$L(STR):-1:1 Q:$E(STR,LEN)'=" "
  1. S STR=$TR(STR,";",",")
  1. Q $E(STR,1,LEN)
  1. ;
  1. DSC(FILE,VALUE,FIELD) ; Look up code descriptions
  1. N IEN
  1. I '$G(FILE)!($G(VALUE)="")!('$G(FIELD)) Q ""
  1. I '$D(^BPS(FILE)) Q ""
  1. I '$D(^BPS(FILE,"B",VALUE)) Q ""
  1. S IEN=$O(^BPS(FILE,"B",VALUE,"")) I '$D(^BPS(FILE,IEN)) Q ""
  1. Q $$GET1^DIQ(FILE,IEN,FIELD)
  1. ;
  1. SMAOVR(RSC,NUM) ; - Ask for OVERRIDE codes - allows deletion of defaults - PSO*7*421
  1. ; Called by SMA^PSOREJP1 (SMA action)
  1. ;
  1. ; INPUT: RSC - Reason for Service code
  1. ; NUM - Sequence number (1-3)
  1. ;
  1. N COD1,COD2,COD3 W !
  1. I RSC]"" S COD1=$$OVRCOD1($G(RSC),NUM) I COD1="^"!(COD1="")!(COD1="@") Q COD1
  1. I RSC']"" S COD1=$$OVRCOD2(1,$G(RSC),NUM) I COD1="^"!(COD1="") Q COD1
  1. S COD2=$$OVRCOD2(2,"",NUM) I COD2="^" Q "^"
  1. S COD3=$$OVRCOD2(3,"",NUM) I COD3="^" Q "^"
  1. Q (COD1_U_COD2_U_COD3)
  1. ;
  1. IGNORE(RX,RFL) ;
  1. ; RX = Prescription IEN
  1. ; RFL = Refill
  1. ; Return value 1 = Allow IGNORE.
  1. ; Return value 0 = Don't allow IGNORE.
  1. ; Return value 0^GrossAmtDue = Don't allow. Return amt for user msg.
  1. ;
  1. N DIR,DIRUT,PSOAMT,PSODIV,PSODIVIEN,PSOIGNORE
  1. ;
  1. ; Get Gross Amount Due
  1. S PSOAMT=$$AMT^BPSBUTL(RX,RFL) ; DBIA #4719
  1. ;
  1. ; Get Ignore Threshold Value
  1. S PSODIV=$$GET1^DIQ(52,RX,20,"I")
  1. S PSODIVIEN=$O(^PS(52.86,"B",PSODIV,""))
  1. S PSOIGNORE=$$GET1^DIQ(52.86,PSODIVIEN,7)
  1. ;
  1. ; If Ignore Threshold is NIL or Gross Amt Due < Ignore
  1. ; Threshold - Allow IGNORE. Check of security key not
  1. ; required for these conditions.
  1. I (PSOIGNORE="")!(PSOAMT<PSOIGNORE) Q 1
  1. ;
  1. ; At this point Gross Amt Due is equal to or greater
  1. ; than the Ignore Threshold. User must have required
  1. ; security key to continue.
  1. ;
  1. S PSOAMT=$J(PSOAMT*100\1/100,0,2)
  1. ;
  1. ; User does not have required security key to continue.
  1. ; Don't allow IGNORE. Return PSOAMT to be used in message
  1. ; to user.
  1. I '$D(^XUSEC("PSO EPHARMACY SITE MANAGER",DUZ)) Q 0_"^"_PSOAMT
  1. ;
  1. ; User has required security key. Prompt if OK to continue.
  1. S DIR(0)="Y"
  1. S DIR("A")="Gross Amount Due is $"_PSOAMT_". Do you want to continue (Y/N)"
  1. S DIR("B")="NO"
  1. D ^DIR
  1. I $D(DIRUT) Q 0
  1. Q Y