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**;DEC 1997;Build 107
  1.  ;Reference to File 9002313.21 - BPS NCPDP PROFESSIONAL SERVICE CODE supported by IA 4712
  1.  ;Reference to File 9002313.22 - BPS NCPDP RESULT OF SERVICE CODE supported by IA 4713
  1.  ;Reference to File 9002313.23 - BPS NCPDP REASON FOR SERVICE CODE supported by IA 4714
  1.  ;Reference to File 200 - NEW PERSON supported by IA 10060
  1.  ;Reference to SIG^XUSESIG supported by IA 10050
  1.  ;
  1. ACTION(RX,REJ,OPTS,DEF) ;
  1.  ; Input:  (r) RX   - Rx IEN (#52) 
  1.  ;         (r) REJ  - REJECT ID (IEN)
  1.  ;         (r) OPTS - Available options ("QIO" for QUIT/IGNORE/OVERRIDE)
  1.  ;         (o) DEF  - Default Option ("O", "I" or "Q")
  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.  ;                 "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 DUR/79 REJECT information
  1.  D DISPLAY^PSOREJU3(RX,REJ)
  1.  ;
  1. ASK 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 D ^DIR I $D(DIRUT) W ! Q "Q"
  1.  ;
  1.  ; - STOP/QUIT Action
  1.  S ACTION=Y I ACTION="Q" Q ACTION
  1.  ;
  1.  ; - IGNORE Action 
  1.  K DIR,DIRUT,X
  1.  I ACTION="I" S COM=$$COM() 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) I $D(DIRUT) S ACTION="D" D DISPLAY^PSOREJU3(RX,REJ) G ASK
  1.  ;
  1.  Q ACTION
  1.  ;
  1. DC(RX,ACTION) ; - Discontinue inside and outside call
  1.  N RXN,MSG,REA,DA,PSCAN,RXNUM
  1.  S DA=RX,RXNUM=""
  1.  D NOOR^PSOCAN4 I $D(DIRUT) W $C(7)," ACTION NOT TAKEN!",! H 1 S PSORX("DFLG")=1,ACTION="Q" Q ACTION
  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.  N PSOCKDC S PSOCKDC=1,PSOQFLAG=1,PSOLST(1)=52_"^"_DA_"^"_$$GET1^DIQ(52,RXNUM,100),ORN=1
  1.  D ECME^PSORXL1 I '$G(PPL) S PPL=""  ;remove rx from label print
  1.  Q ACTION
  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 I $D(DIRUT) S COM="^"
  1.  Q COM
  1.  ;
  1. OVR() ; - Ask for OVERRIDE codes
  1.  N COD1,COD2,COD3,DIR,DIRUT W !
  1.  S COD1=$$OVRCOD(1,$$GET1^DIQ(52.25,REJ_","_RX,14)) I COD1="^" Q "^"
  1.  S COD2=$$OVRCOD(2) I COD2="^" Q "^"
  1.  S COD3=$$OVRCOD(3) I COD3="^" Q "^"
  1.  ;
  1.  D OVRDSP^PSOREJU1(COD1_"^"_COD2_"^"_COD3) W !
  1.  ;
  1.  S DIR(0)="Y",DIR("A")="     Confirm? ",DIR("B")="YES"
  1.  D ^DIR I $G(Y)=0!$D(DIRUT) Q "^"
  1.  ;
  1.  Q (COD2_"^"_COD1_"^"_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 Clarification Code
  1.  N DIR,Y,DIRUT,DIROUT
  1.  S DIR(0)="52.25,24",DIR("A")="Clarification Code" D ^DIR
  1.  I $D(DIRUT)!$D(DIROUT) Q "^"
  1.  Q Y
  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")
  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,"^"-Up-arrow entered
  1.  ;       
  1.  N REJDATA,NEWDATA,CODE,ACTION,REJ,RESP,REJCDI,PSOTRIC,DCODE S CODE=""
  1.  I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  1.  S PSOTRIC="",PSOTRIC=$$TRIC^PSOREJP1(RX,RFL,PSOTRIC)
  1.  I PSOTRIC D  ;note that Tricare Rejects need all codes, not just 79/88's
  1.  . S OPTS="DQ",DEF="Q",(DCODE,CODES)=""
  1.  . F  S DCODE=$O(^PSRX(RX,"REJ","B",DCODE)) Q:DCODE=""  S CODES=CODES_","_DCODE
  1.  . S CODES=$E(CODES,2,9999)
  1.  . I CODES["88"!(CODES["79") S OPTS="ODQ"
  1.  ;  -  In progress Rx not allowed to be filled
  1.  I PSOTRIC,$$STATUS^PSOBPSUT(RX,RFL)["IN PROGRESS" S ACTION="",(DEF,OPTS)="D" D TRICCHK^PSOREJU3(RX,RFL,"",FROM) D  Q ACTION
  1.  . I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,7,,$P(ACTION,"^",2))
  1.  ;
  1.  F REJCDI=1:1 S CODE=$P(CODES,",",REJCDI) Q:CODE=""  D  I ACTION="Q"!(ACTION="^") Q
  1.  . S ACTION=""
  1.  . I $$FIND^PSOREJUT(RX,RFL,.REJDATA,CODE) D
  1.  . . S REJ=$O(REJDATA(""))
  1.  . . S ACTION=$$ACTION(RX,REJ,OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q
  1.  . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2)) Q
  1.  . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",3),$P(ACTION,"^",2),$P(ACTION,"^",4))
  1.  . . I $P(ACTION,"^")="D" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,7,,$P(ACTION,"^",2)) Q
  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.  . . K NEWDATA I $$FIND^PSOREJUT(RX,RFL,.NEWDATA,CODE) D  I ACTION="Q"!(ACTION="^") Q
  1.  . . . S ACTION=$$ACTION(RX,$O(NEWDATA("")),OPTS,$G(DEF)) I ACTION="Q"!(ACTION="^") Q
  1.  . . . I $P(ACTION,"^")="I" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,6,$P(ACTION,"^",2))
  1.  . . . I $P(ACTION,"^")="O" D CLOSE^PSOREJUT(RX,RFL,REJ,DUZ,1,,$P(ACTION,"^",3),$P(ACTION,"^",2),$P(ACTION,"^",4))
  1.  Q ACTION
  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=1 Q CODE_" - "_$$GET1^DIQ(9002313.23,+Y,1)
  1.  I TYPE=2 Q CODE_" - "_$$GET1^DIQ(9002313.21,+Y,1)
  1.  I TYPE=3 Q CODE_" - "_$$GET1^DIQ(9002313.22,+Y,1)
  1.  Q ""
  1.  ;
  1.  ;
  1. OVRCOD(TYPE,VALUE) ; - Prompt for NCPDP Override Codes
  1.  N DIC,X,Y,FILE,PRPT
  1.  ; 
  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)="Z"
  1.  I $G(VALUE)'="" S X=VALUE D ^DIC I Y>0 W !,PRPT,VALUE,"       ",$P(Y(0),"^",2) Q VALUE
  1.  S DIC=FILE,DIC(0)="AQE",DIC("A")=PRPT
  1.  D ^DIC I $D(DTOUT)!$D(DUOUT)!(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) ; Checks if REJECT has already been logged in the PRESCRIPTION file
  1.  ; Input:  (r) RX  - Rx IEN (#52) 
  1.  ;         (o) RSP - Response IEN
  1.  ; Output:     DUP - 1: Already logged (duplicate) 
  1.  ;                   0: Not yet logged on PRESCRIPTION file
  1.  N DUP,IDX 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.  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)
  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)
  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)