- 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