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

ABSPER10.m

Go to the documentation of this file.
  1. 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
  1. ;----------------------------------------------------------------------
  1. ;----------------------------------------------------------------------
  1. ;Pharmacy Claim Rejection Report (by Tran Date, SORTed by Insurer)
  1. ;----------------------------------------------------------------------
  1. EN ; option ABSP REJECTION REPORT
  1. N SCRNTXT,SDATE,EDATE,ANS,XBRP,J,XBNS,RPTNAME,PREFIXES,POP
  1. ;
  1. D DT^DICRW
  1. D HOME^%ZIS
  1. ;
  1. S RPTNAME="RX RJCT RPT"
  1. S SCRNTXT="Pharmacy Claim Rejection Report (by Transmission Date)"
  1. D WHEADER^ABSPOSU9(SCRNTXT,IOF,IOM)
  1. W !
  1. ;
  1. ; Prefixes
  1. S PREFIXES=$$PREFIXES Q:"^"[PREFIXES
  1. ;
  1. ;Start Date Prompt
  1. S (SDATE,EDATE)="; no, let it go through ; "
  1. LP1 S ANS=$$DATE^ABSPOSU1("Transmission - Start Date: ",SDATE,1,"","DT","E",DTIME)
  1. G:ANS=-1!(ANS="^")!(ANS="^^")!(ANS="") EXIT
  1. S SDATE=ANS
  1. ;
  1. ;End Date Prompt
  1. LP2 S ANS=$$DATE^ABSPOSU1("Transmission - End Date: ",EDATE,1,SDATE,"DT","E",DTIME)
  1. I ANS="^" D WHEADER^ABSPOSU9(SCRNTXT,IOF,IOM) G LP1
  1. G:ANS=-1!(ANS="^^")!(ANS="") EXIT
  1. S EDATE=ANS
  1. ;
  1. D ^%ZIS Q:$G(POP) G RPT ; queueing stuff fails at Sitka ; 04/13/2000
  1. S XBRP="RPT^ABSPER10"
  1. F J="SDATE","EDATE","SCRNTXT","RPTNAME","PREFIXES" S XBNS(J)=""
  1. D ^XBDBQUE
  1. EXIT Q
  1. ;----------------------------------------------------------------------
  1. RPT N PAGE
  1. U IO
  1. K ^TMP($J,RPTNAME)
  1. D SORT
  1. D PRINT^ABSPER1A
  1. D ^%ZISC
  1. K ^TMP($J,RPTNAME)
  1. Q
  1. ;----------------------------------------------------------------------
  1. SORT N DATE1,DATE2,TDATE,RESPIEN,MEDIEN,CLAIMIEN,DATA,CLAIMID,INSIEN
  1. N INSNAME,INSHELP,BITEMIEN,PCN,PATNAME,CARDID,NDC
  1. N RJCTNEXT,RJCTCNT,RJCTIEN,RJCTTEXT,RJCTCODE,DIALOUT S DIALOUT=1
  1. ;
  1. S DATE1=$$CDTFM^ABSPOSU1(SDATE,-1)_".245959"
  1. S DATE2=EDATE_".245959"
  1. K ^TMP($J,RPTNAME)
  1. ; no, let it go through ; Q:IOM<132
  1. ;
  1. ;Loop through "AE" x-ref and gather responses within date range
  1. S TDATE=DATE1
  1. F D Q:TDATE=""!(TDATE>DATE2)
  1. .S TDATE=$O(^ABSPR("AE",TDATE))
  1. .Q:TDATE=""!(TDATE>DATE2)
  1. .S RESPIEN=0
  1. .F D Q:'+RESPIEN
  1. ..S RESPIEN=$O(^ABSPR("AE",TDATE,RESPIEN))
  1. ..Q:'+RESPIEN
  1. ..;Determine if response has rejections
  1. ..Q:'$DATA(^ABSPR("AC","R",RESPIEN))
  1. ..;Loop through rejection index and get medication records
  1. ..S MEDIEN=0
  1. ..F D Q:'MEDIEN
  1. ...S MEDIEN=$O(^ABSPR("AC","R",RESPIEN,MEDIEN))
  1. ...Q:'+MEDIEN
  1. ...;Get needed data from 9002313.02 file
  1. ...S CLAIMIEN=$P($G(^ABSPR(RESPIEN,0)),U,1)
  1. ...Q:CLAIMIEN=""
  1. ...Q:'$DATA(^ABSPC(CLAIMIEN,0))
  1. ...S DATA=$G(^ABSPC(CLAIMIEN,0))
  1. ...S CLAIMID=$P(DATA,U,1)
  1. ...I PREFIXES]"",PREFIXES'[$E(CLAIMID) Q ; is it one of our claims?
  1. ...S INSIEN=$P(DATA,U,2)
  1. ...Q:'+INSIEN
  1. ...S INSNAME=$P($G(^AUTNINS(INSIEN,0)),U,1)
  1. ...Q:INSNAME=""
  1. ...S INSHELP=$$INSHELP(INSIEN)
  1. ...S BITEMIEN=$P(DATA,U,3)
  1. ...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
  1. ...I PCN="" S PCN="RX# "_$$RXNUM^ABSPER20 ;"RX# `"_+$P($G(^ABSPC(CLAIMIEN,400,MEDIEN,400)),U,2)
  1. ...S PATNAME=$P($G(^ABSPC(CLAIMIEN,1)),U,1)
  1. ...S DATA=$G(^ABSPC(CLAIMIEN,300))
  1. ...S CARDID=$P(DATA,U,2)
  1. ...S DATA=$G(^ABSPC(CLAIMIEN,400,MEDIEN,400))
  1. ...S NDC=$$FORMTNDC^ABSPOS9($P(DATA,U,7)) ; DRS; 04/13/2000
  1. ...;Get Rejection Reasons from 9002313.03 for Medication record
  1. ...S (RJCTNEXT,RJCTCNT)=0
  1. ...F D Q:'+RJCTNEXT
  1. ....S RJCTNEXT=$O(^ABSPR(RESPIEN,1000,MEDIEN,511,RJCTNEXT))
  1. ....Q:'+RJCTNEXT
  1. ....S RJCTIEN=+$G(^ABSPR(RESPIEN,1000,MEDIEN,511,RJCTNEXT,0))
  1. ....Q:RJCTIEN<1
  1. ....S RJCTTEXT=$P($G(^ABSPF(9002313.93,RJCTIEN,0)),U,2)
  1. ....S RJCTCODE=$P($G(^ABSPF(9002313.93,RJCTIEN,0)),U)
  1. ....Q:RJCTTEXT=""
  1. ....S RJCTCNT=RJCTCNT+1
  1. ....S ^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTCNT)=RJCTCODE_":"_RJCTTEXT
  1. ...D
  1. ....N X S X=$G(^ABSPR(RESPIEN,1000,MEDIEN,504))
  1. ....N Y S Y=$G(^ABSPR(RESPIEN,1000,MEDIEN,526))
  1. ....I X]""!(Y]"") S RJCTCNT=RJCTCNT+1,^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN,RJCTCNT)=X_Y
  1. ...S ^TMP($J,RPTNAME,INSNAME,TDATE,RESPIEN,MEDIEN)=CLAIMID_U_PCN_U_PATNAME_U_CARDID_U_NDC_U_RJCTCNT
  1. ...S ^TMP($J,RPTNAME,INSNAME)=INSHELP
  1. Q
  1. PREFIXES() ;EP - from ABSPER20 and ABSPER10
  1. N DIR,DTOUT,DUOUT,X,Y S DIR(0)="FAO^1:10"
  1. S DIR("A")="Which claim ID prefixes to report? ",DIR("B")=$$PREFLIST
  1. I $L(DIR("B"))<2 Q DIR("B") ; don't bug 'em if it's obvious
  1. D ^DIR
  1. S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. Q X
  1. INSHELP(IEN) ;EP - from ABSPER20 and ABSPER10
  1. N % S %=$P($G(^ABSPEI(IEN,100)),U,5)
  1. I %]"" Q %
  1. N FMT S FMT=$P($G(^ABSPEI(IEN,100)),U)
  1. I FMT Q $P($G(^ABSPF(9002313.92,1)),U,5)
  1. Q ""
  1. PREFLIST() ; return a list of the prefixes in use
  1. N X,LIST S X="A",LIST=""
  1. F D Q:X=""
  1. . S X=$O(^ABSPC("B",X)) Q:X=""
  1. . S LIST=LIST_$E(X)
  1. . S X=$E(X)_"ZZZZZZZZZZZ"
  1. Q LIST