ABSPER10 ; IHS/FCS/DRS - JWS 03:58 PM 16 Jul 1996 ; [ 09/12/2002 10:01 AM ]
;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;Pharmacy Claim Rejection Report (by Tran Date, SORTed by Insurer)
;----------------------------------------------------------------------
EN ; option ABSP REJECTION REPORT
N SCRNTXT,SDATE,EDATE,ANS,XBRP,J,XBNS,RPTNAME,PREFIXES,POP
;
D DT^DICRW
D HOME^%ZIS
;
S RPTNAME="RX RJCT RPT"
S SCRNTXT="Pharmacy Claim Rejection Report (by Transmission Date)"
D WHEADER^ABSPOSU9(SCRNTXT,IOF,IOM)
W !
;
; Prefixes
S PREFIXES=$$PREFIXES Q:"^"[PREFIXES
;
;Start Date Prompt
S (SDATE,EDATE)="; no, let it go through ; "
LP1 S ANS=$$DATE^ABSPOSU1("Transmission - Start Date: ",SDATE,1,"","DT","E",DTIME)
G:ANS=-1!(ANS="^")!(ANS="^^")!(ANS="") EXIT
S SDATE=ANS
;
;End Date Prompt
LP2 S ANS=$$DATE^ABSPOSU1("Transmission - End Date: ",EDATE,1,SDATE,"DT","E",DTIME)
I ANS="^" D WHEADER^ABSPOSU9(SCRNTXT,IOF,IOM) G LP1
G:ANS=-1!(ANS="^^")!(ANS="") EXIT
S EDATE=ANS
;
D ^%ZIS Q:$G(POP) G RPT ; queueing stuff fails at Sitka ; 04/13/2000
S XBRP="RPT^ABSPER10"
F J="SDATE","EDATE","SCRNTXT","RPTNAME","PREFIXES" S XBNS(J)=""
D ^XBDBQUE
EXIT Q
;----------------------------------------------------------------------
RPT N PAGE
U IO
K ^TMP($J,RPTNAME)
D SORT
D PRINT^ABSPER1A
D ^%ZISC
K ^TMP($J,RPTNAME)
Q
;----------------------------------------------------------------------
SORT N DATE1,DATE2,TDATE,RESPIEN,MEDIEN,CLAIMIEN,DATA,CLAIMID,INSIEN
N INSNAME,INSHELP,BITEMIEN,PCN,PATNAME,CARDID,NDC
N RJCTNEXT,RJCTCNT,RJCTIEN,RJCTTEXT,RJCTCODE,DIALOUT S DIALOUT=1
;
S DATE1=$$CDTFM^ABSPOSU1(SDATE,-1)_".245959"
S DATE2=EDATE_".245959"
K ^TMP($J,RPTNAME)
; no, let it go through ; Q:IOM<132
;
;Loop through "AE" x-ref and gather responses within date range
S TDATE=DATE1
F D Q:TDATE=""!(TDATE>DATE2)
.S TDATE=$O(^ABSPR("AE",TDATE))
.Q:TDATE=""!(TDATE>DATE2)
.S RESPIEN=0
.F D Q:'+RESPIEN
..S RESPIEN=$O(^ABSPR("AE",TDATE,RESPIEN))
..Q:'+RESPIEN
..;Determine if response has rejections
..Q:'$DATA(^ABSPR("AC","R",RESPIEN))
..;Loop through rejection index and get medication records
..S MEDIEN=0
..F D Q:'MEDIEN
...S MEDIEN=$O(^ABSPR("AC","R",RESPIEN,MEDIEN))
...Q:'+MEDIEN
...;Get needed data from 9002313.02 file
...S CLAIMIEN=$P($G(^ABSPR(RESPIEN,0)),U,1)
...Q:CLAIMIEN=""
...Q:'$DATA(^ABSPC(CLAIMIEN,0))
...S DATA=$G(^ABSPC(CLAIMIEN,0))
...S CLAIMID=$P(DATA,U,1)
...I PREFIXES]"",PREFIXES'[$E(CLAIMID) Q ; is it one of our claims?
...S INSIEN=$P(DATA,U,2)
...Q:'+INSIEN
...S INSNAME=$P($G(^AUTNINS(INSIEN,0)),U,1)
...Q:INSNAME=""
...S INSHELP=$$INSHELP(INSIEN)
...S BITEMIEN=$P(DATA,U,3)
...S PCN=$S(BITEMIEN="":"",$P($G(^ABSP(9002313.99,+$G(DIALOUT),2)),U,1)="VCN":$P($G(^ABSBITMS(9002302,BITEMIEN,"VCN")),U,1),1:$P($G(^ABSBITMS(9002302,BITEMIEN,0)),U,1)) ;either PCN or VCN displays
...I PCN="" S PCN="RX# "_$$RXNUM^ABSPER20 ;"RX# `"_+$P($G(^ABSPC(CLAIMIEN,400,MEDIEN,400)),U,2)
...S PATNAME=$P($G(^ABSPC(CLAIMIEN,1)),U,1)
...S DATA=$G(^ABSPC(CLAIMIEN,300))
...S CARDID=$P(DATA,U,2)
...S DATA=$G(^ABSPC(CLAIMIEN,400,MEDIEN,400))
...S NDC=$$FORMTNDC^ABSPOS9($P(DATA,U,7)) ; DRS; 04/13/2000
...;Get Rejection Reasons from 9002313.03 for Medication record
...S (RJCTNEXT,RJCTCNT)=0
...F D Q:'+RJCTNEXT
....S RJCTNEXT=$O(^ABSPR(RESPIEN,1000,MEDIEN,511,RJCTNEXT))
....Q:'+RJCTNEXT
....S RJCTIEN=+$G(^ABSPR(RESPIEN,1000,MEDIEN,511,RJCTNEXT,0))
....Q:RJCTIEN<1
....S RJCTTEXT=$P($G(^ABSPF(9002313.93,RJCTIEN,0)),U,2)
....S RJCTCODE=$P($G(^ABSPF(9002313.93,RJCTIEN,0)),U)
....Q:RJCTTEXT=""
....S RJCTCNT=RJCTCNT+1
....S ^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTCNT)=RJCTCODE_":"_RJCTTEXT
...D
....N X S X=$G(^ABSPR(RESPIEN,1000,MEDIEN,504))
....N Y S Y=$G(^ABSPR(RESPIEN,1000,MEDIEN,526))
....I X]""!(Y]"") S RJCTCNT=RJCTCNT+1,^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTCNT)=X_Y
...S ^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)=CLAIMID_U_PCN_U_PATNAME_U_CARDID_U_NDC_U_RJCTCNT
...S ^TMP($J,RPTNAME,INSNAME)=INSHELP
Q
PREFIXES() ;EP - from ABSPER20 and ABSPER10
N DIR,DTOUT,DUOUT,X,Y S DIR(0)="FAO^1:10"
S DIR("A")="Which claim ID prefixes to report? ",DIR("B")=$$PREFLIST
I $L(DIR("B"))<2 Q DIR("B") ; don't bug 'em if it's obvious
D ^DIR
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
INSHELP(IEN) ;EP - from ABSPER20 and ABSPER10
N % S %=$P($G(^ABSPEI(IEN,100)),U,5)
I %]"" Q %
N FMT S FMT=$P($G(^ABSPEI(IEN,100)),U)
I FMT Q $P($G(^ABSPF(9002313.92,1)),U,5)
Q ""
PREFLIST() ; return a list of the prefixes in use
N X,LIST S X="A",LIST=""
F D Q:X=""
. S X=$O(^ABSPC("B",X)) Q:X=""
. S LIST=LIST_$E(X)
. S X=$E(X)_"ZZZZZZZZZZZ"
Q LIST
ABSPER10 ; IHS/FCS/DRS - JWS 03:58 PM 16 Jul 1996 ; [ 09/12/2002 10:01 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
+2 ;----------------------------------------------------------------------
+3 ;----------------------------------------------------------------------
+4 ;Pharmacy Claim Rejection Report (by Tran Date, SORTed by Insurer)
+5 ;----------------------------------------------------------------------
EN ; option ABSP REJECTION REPORT
+1 NEW SCRNTXT,SDATE,EDATE,ANS,XBRP,J,XBNS,RPTNAME,PREFIXES,POP
+2 ;
+3 DO DT^DICRW
+4 DO HOME^%ZIS
+5 ;
+6 SET RPTNAME="RX RJCT RPT"
+7 SET SCRNTXT="Pharmacy Claim Rejection Report (by Transmission Date)"
+8 DO WHEADER^ABSPOSU9(SCRNTXT,IOF,IOM)
+9 WRITE !
+10 ;
+11 ; Prefixes
+12 SET PREFIXES=$$PREFIXES
IF "^"[PREFIXES
QUIT
+13 ;
+14 ;Start Date Prompt
+15 SET (SDATE,EDATE)="; no, let it go through ; "
LP1 SET ANS=$$DATE^ABSPOSU1("Transmission - Start Date: ",SDATE,1,"","DT","E",DTIME)
+1 IF ANS=-1!(ANS="^")!(ANS="^^")!(ANS="")
GOTO EXIT
+2 SET SDATE=ANS
+3 ;
+4 ;End Date Prompt
LP2 SET ANS=$$DATE^ABSPOSU1("Transmission - End Date: ",EDATE,1,SDATE,"DT","E",DTIME)
+1 IF ANS="^"
DO WHEADER^ABSPOSU9(SCRNTXT,IOF,IOM)
GOTO LP1
+2 IF ANS=-1!(ANS="^^")!(ANS="")
GOTO EXIT
+3 SET EDATE=ANS
+4 ;
+5 ; queueing stuff fails at Sitka ; 04/13/2000
DO ^%ZIS
IF $GET(POP)
QUIT
GOTO RPT
+6 SET XBRP="RPT^ABSPER10"
+7 FOR J="SDATE","EDATE","SCRNTXT","RPTNAME","PREFIXES"
SET XBNS(J)=""
+8 DO ^XBDBQUE
EXIT QUIT
+1 ;----------------------------------------------------------------------
RPT NEW PAGE
+1 USE IO
+2 KILL ^TMP($JOB,RPTNAME)
+3 DO SORT
+4 DO PRINT^ABSPER1A
+5 DO ^%ZISC
+6 KILL ^TMP($JOB,RPTNAME)
+7 QUIT
+8 ;----------------------------------------------------------------------
SORT NEW DATE1,DATE2,TDATE,RESPIEN,MEDIEN,CLAIMIEN,DATA,CLAIMID,INSIEN
+1 NEW INSNAME,INSHELP,BITEMIEN,PCN,PATNAME,CARDID,NDC
+2 NEW RJCTNEXT,RJCTCNT,RJCTIEN,RJCTTEXT,RJCTCODE,DIALOUT
SET DIALOUT=1
+3 ;
+4 SET DATE1=$$CDTFM^ABSPOSU1(SDATE,-1)_".245959"
+5 SET DATE2=EDATE_".245959"
+6 KILL ^TMP($JOB,RPTNAME)
+7 ; no, let it go through ; Q:IOM<132
+8 ;
+9 ;Loop through "AE" x-ref and gather responses within date range
+10 SET TDATE=DATE1
+11 FOR
Begin DoDot:1
+12 SET TDATE=$ORDER(^ABSPR("AE",TDATE))
+13 IF TDATE=""!(TDATE>DATE2)
QUIT
+14 SET RESPIEN=0
+15 FOR
Begin DoDot:2
+16 SET RESPIEN=$ORDER(^ABSPR("AE",TDATE,RESPIEN))
+17 IF '+RESPIEN
QUIT
+18 ;Determine if response has rejections
+19 IF '$DATA(^ABSPR("AC","R",RESPIEN))
QUIT
+20 ;Loop through rejection index and get medication records
+21 SET MEDIEN=0
+22 FOR
Begin DoDot:3
+23 SET MEDIEN=$ORDER(^ABSPR("AC","R",RESPIEN,MEDIEN))
+24 IF '+MEDIEN
QUIT
+25 ;Get needed data from 9002313.02 file
+26 SET CLAIMIEN=$PIECE($GET(^ABSPR(RESPIEN,0)),U,1)
+27 IF CLAIMIEN=""
QUIT
+28 IF '$DATA(^ABSPC(CLAIMIEN,0))
QUIT
+29 SET DATA=$GET(^ABSPC(CLAIMIEN,0))
+30 SET CLAIMID=$PIECE(DATA,U,1)
+31 ; is it one of our claims?
IF PREFIXES]""
IF PREFIXES'[$EXTRACT(CLAIMID)
QUIT
+32 SET INSIEN=$PIECE(DATA,U,2)
+33 IF '+INSIEN
QUIT
+34 SET INSNAME=$PIECE($GET(^AUTNINS(INSIEN,0)),U,1)
+35 IF INSNAME=""
QUIT
+36 SET INSHELP=$$INSHELP(INSIEN)
+37 SET BITEMIEN=$PIECE(DATA,U,3)
+38 ;either PCN or VCN displays
SET PCN=$SELECT(BITEMIEN="":"",$PIECE($GET(^ABSP(9002313.99,+$GET(DIALOUT),2)),U,1)="VCN":$PIECE($GET(^ABSBITMS(9002302,BITEMIEN,"VCN")),U,1),1:$PIECE($GET(^ABSBITMS(9002302,BITEMIEN,0)),U,1))
+39 ;"RX# `"_+$P($G(^ABSPC(CLAIMIEN,400,MEDIEN,400)),U,2)
IF PCN=""
SET PCN="RX# "_$$RXNUM^ABSPER20
+40 SET PATNAME=$PIECE($GET(^ABSPC(CLAIMIEN,1)),U,1)
+41 SET DATA=$GET(^ABSPC(CLAIMIEN,300))
+42 SET CARDID=$PIECE(DATA,U,2)
+43 SET DATA=$GET(^ABSPC(CLAIMIEN,400,MEDIEN,400))
+44 ; DRS; 04/13/2000
SET NDC=$$FORMTNDC^ABSPOS9($PIECE(DATA,U,7))
+45 ;Get Rejection Reasons from 9002313.03 for Medication record
+46 SET (RJCTNEXT,RJCTCNT)=0
+47 FOR
Begin DoDot:4
+48 SET RJCTNEXT=$ORDER(^ABSPR(RESPIEN,1000,MEDIEN,511,RJCTNEXT))
+49 IF '+RJCTNEXT
QUIT
+50 SET RJCTIEN=+$GET(^ABSPR(RESPIEN,1000,MEDIEN,511,RJCTNEXT,0))
+51 IF RJCTIEN<1
QUIT
+52 SET RJCTTEXT=$PIECE($GET(^ABSPF(9002313.93,RJCTIEN,0)),U,2)
+53 SET RJCTCODE=$PIECE($GET(^ABSPF(9002313.93,RJCTIEN,0)),U)
+54 IF RJCTTEXT=""
QUIT
+55 SET RJCTCNT=RJCTCNT+1
+56 SET ^TMP($JOB,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTCNT)=RJCTCODE_":"_RJCTTEXT
End DoDot:4
IF '+RJCTNEXT
QUIT
+57 Begin DoDot:4
+58 NEW X
SET X=$GET(^ABSPR(RESPIEN,1000,MEDIEN,504))
+59 NEW Y
SET Y=$GET(^ABSPR(RESPIEN,1000,MEDIEN,526))
+60 IF X]""!(Y]"")
SET RJCTCNT=RJCTCNT+1
SET ^TMP($JOB,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTCNT)=X_Y
End DoDot:4
+61 SET ^TMP($JOB,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)=CLAIMID_U_PCN_U_PATNAME_U_CARDID_U_NDC_U_RJCTCNT
+62 SET ^TMP($JOB,RPTNAME,INSNAME)=INSHELP
End DoDot:3
IF 'MEDIEN
QUIT
End DoDot:2
IF '+RESPIEN
QUIT
End DoDot:1
IF TDATE=""!(TDATE>DATE2)
QUIT
+63 QUIT
PREFIXES() ;EP - from ABSPER20 and ABSPER10
+1 NEW DIR,DTOUT,DUOUT,X,Y
SET DIR(0)="FAO^1:10"
+2 SET DIR("A")="Which claim ID prefixes to report? "
SET DIR("B")=$$PREFLIST
+3 ; don't bug 'em if it's obvious
IF $LENGTH(DIR("B"))<2
QUIT DIR("B")
+4 DO ^DIR
+5 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+6 QUIT X
INSHELP(IEN) ;EP - from ABSPER20 and ABSPER10
+1 NEW %
SET %=$PIECE($GET(^ABSPEI(IEN,100)),U,5)
+2 IF %]""
QUIT %
+3 NEW FMT
SET FMT=$PIECE($GET(^ABSPEI(IEN,100)),U)
+4 IF FMT
QUIT $PIECE($GET(^ABSPF(9002313.92,1)),U,5)
+5 QUIT ""
PREFLIST() ; return a list of the prefixes in use
+1 NEW X,LIST
SET X="A"
SET LIST=""
+2 FOR
Begin DoDot:1
+3 SET X=$ORDER(^ABSPC("B",X))
IF X=""
QUIT
+4 SET LIST=LIST_$EXTRACT(X)
+5 SET X=$EXTRACT(X)_"ZZZZZZZZZZZ"
End DoDot:1
IF X=""
QUIT
+6 QUIT LIST
