ABSPOSRZ ;IHS/OIT/SCR - REJECTION REPORT BY REJECTION REASON
;;1.0;PHARMACY POINT OF SALE;**29,30,34,35,39,40,41,44,46**;JUN 21, 2001;Build 38
;IHS/OIT/CNI/RAN - Rewritten for patch 40 to run WITHOUT Report Master
;OIT/CAS/RCS - Fix report to look at only latest claim data not earlier claims, patch 44
;IHS/OIT/RCS - Fix program error when Reject code is not in table, patch 46
;IHS/OIT/RCS - Change ABSPCLMS variable to scratch file to fix STORE errors, patch 46
EN ; EP
N ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT,ABSPREJ,ABSPRJ
I $D(ZTQPARAM) D START
S ABSPDONE=0
S ABSPQUIT=0
F Q:ABSPDONE=1 D
.S ABSPSTRT=$$BDT^ABSPOSRU()
.I ABSPSTRT=-1 D
..S ABSPQUIT=1
..S ABSPDONE=1
.Q:ABSPQUIT
.S ABSPEND=$$EDT^ABSPOSRU()
.I ABSPEND=-1 D
..S ABSPQUIT=1
..S ABSPDONE=1
..Q
.Q:ABSPQUIT
.I ABSPSTRT<0 S ABSPDONE=1 Q
.I ABSPEND<0 S ABSPDONE=1 Q
.S X2=ABSPSTRT,X1=ABSPEND D ^%DTC
.I X<0 D EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")
.I X>=0 S ABSPDONE=1
.Q
Q:ABSPQUIT
S ABSPQUIT=$$CLNC^ABSPOSRU()
Q:ABSPQUIT=-1
S ABSPQUIT=$$INS^ABSPOSUU()
Q:ABSPQUIT=-1
S ABSPQUIT=$$CODE^ABSPOSUU() ;IHS/OIT/SCR 092109 patch 34 - screen by selected reject code
Q:ABSPQUIT=-1
S ABSPQUIT=$$RTYPE()
Q
RTYPE() ; SELECT IF YOU WANT SUMMARY, OR DETAILED
N DIR,STARTIME,STOPTIME
S DIR(0)="S^S:SUMMARY;D:DETAILED"
S DIR("B")="D"
S DIR("A")="Please select S for Summary or D for Detailed"
D ^DIR
I $D(DIRUT) Q -1
S ABSPRTYP=X ; SET REPORT TYPE
D DEVSEL^ABSPOSRU
D ^XBCLS
S STARTIME=$H
D FIND
S STOPTIME=$H
S ^TMP("ABSPOSRZ-RUNLOG",$J,STARTIME)=ABSPSTRT_"^"_$P(ABSPEND,".")_"^"_($P(STOPTIME,",",2)-$P(STARTIME,",",2))
D NEXT
Q 1
FIND ; FIND REJECTIONS BY RELEASE DATE "B" CROSS REFERENCE
N ABSPDONE,ABSPRDT,ABSPCARD,ABSPGRP,ABSPCLMI,ABSPRCNT,ABSPRNUM,ABSPTRTM,ABSPRSMI,ABSPPRMI ;,ABSPCLMS
N ABSPTLTP,ABSPRESC,DO,ABSPIDTS,ABSPIDTE,ABSPIRMI,ABSPIRME
N ABSPCODE,ABSPQUIT ;IHS/OIT/SCR 082109 patch 34
K ^TMP($J,"ABSPCLMS") ;OIT/CAS/RCS 081213 Patch 46
S ABSPRDT=ABSPSTRT
S ABSPEND=ABSPEND_".99999999"
S ABSPDONE=0
F S ABSPRDT=$O(^PSRX("AL",ABSPRDT)) Q:(ABSPRDT="")!(ABSPDONE)!(+ABSPRDT=0) D
.I ABSPRDT>ABSPEND S ABSPDONE=1 Q
.S ^TMP("ABSPOSRZ",$J,$P(ABSPRDT,"."))=""
.S ABSPPRMI=""
.F S ABSPPRMI=$O(^PSRX("AL",ABSPRDT,ABSPPRMI)) Q:ABSPPRMI="" D
..S ABSPIRME=ABSPPRMI
..S ABSPIRMI=ABSPPRMI_".99999999"
..F S ABSPIRMI=$O(^ABSPTL("B",ABSPIRMI),-1) Q:(ABSPIRMI<ABSPIRME)!(ABSPIRMI="") D
...S ABSPTRNS=""
...F S ABSPTRNS=$O(^ABSPTL("B",ABSPIRMI,ABSPTRNS),-1) Q:ABSPTRNS="" D Q ;OIT/CAS/RCS 06202012 Patch 44 - Quit after the oldest/first claim is looked at, HEAT # 71102
....N ABSPTL
....M ABSPTL(ABSPTRNS)=^ABSPTL(ABSPTRNS)
....;DONT REPORT CLOSED CLAIMS
....I +$P($G(ABSPTL(ABSPTRNS,9)),"^") S ^TMP($J,"ABSPCLMS",$P(ABSPIRMI,"."))="" Q ;OIT/CAS/RCS - Patch 46, S ABSPCLMS($P(ABSPIRMI,"."))="" Q
....S ABSPTLTP=ABSPTL(ABSPTRNS,0)
....S ABSPRSMI=$P(ABSPTLTP,U,5) ;Response reference
....S ABSPCLMI=$P(ABSPTLTP,U,4) ;Claim Reference
....Q:(ABSPRSMI="")!(ABSPCLMI="")
....S DO=$P(ABSPTLTP,U,9) ;Position on claim(and response)
....I '$D(^ABSPR(ABSPRSMI,1000,DO)) S DO=$$GETDO^ABSPOSUU(ABSPRSMI,$P(ABSPIRMI,"."))
....Q:DO=""
....;IHS/OIT/CASSEVERN/RAN 03/02/2011 patch 41 If there is a corrupted response just skip it rather than err out
....Q:'$D(^ABSPR(ABSPRSMI,1000,DO,500))
....I $P(^ABSPR(ABSPRSMI,1000,DO,500),U)'="R" S ^TMP($J,"ABSPCLMS",$P(ABSPIRMI,"."))="" ;OIT/CAS/RCS - Patch 46, S ABSPCLMS($P(ABSPIRMI,"."))="" ;We only care about rejects in this report
....Q:$D(^TMP($J,"ABSPCLMS",$P(ABSPIRMI,"."))) ;OIT/CAS/RCS - Patch 46, Q:$D(ABSPCLMS($P(ABSPIRMI,".")))
....S ABSPTINS=$P(ABSPTL(ABSPTRNS,1),U,6)
....S ABSPPHM1=""
....I ABSPINS'="ALL" Q:ABSPTINS'=ABSPINS ;NOT SELECTED INSURER
....I (ABSPPPHM'="ALL")&&($P(ABSPTL(ABSPTRNS,1),U,7)'=ABSPPPHM) Q ;NOT SELECTED PHARMACY
....S ABSPPHM1=ABSPPPHM
....I ABSPPPHM="ALL" S ABSPPHM1=$P(ABSPTL(ABSPTRNS,1),U,7) ;SET PHARMACY
....I ABSPPHM1="" Q
....;IHS/OIT/SCR 082109 START changes patch 34
....I '$D(^ABSPR(ABSPRSMI,1000,DO,511)) S (ABSPRNUM,ABSPREA)="UKN" ;Added to skip junk data in PMAA test area
....E D ;IHS/OIT/RCS 080913 patch 46 If Reject code missing, create unkown Reject description
.....S ABSPRNUM=$P(^ABSPR(ABSPRSMI,1000,DO,511,1,0),U)
.....I '$D(^ABSPF(9002313.93,"B",ABSPRNUM)) S ABSPREA="Reject Code description not entered,See NCPDP Rejects" Q ;IHS/OIT/RCS PATCH 46
.....S ABSPREA=$P(^ABSPF(9002313.93,$O(^ABSPF(9002313.93,"B",ABSPRNUM,"")),0),U,2)
....I (ABSPREJ'="ALL")&&(ABSPREJX'=ABSPRNUM) S ABSPQUIT=1 Q
....S ABSPGRP=""
....S ABSPCARD=""
....S ABSPCARD=$P($G(^ABSPC(ABSPCLMI,300)),U,2) ;TRANSACTION:CLAIM:Cardholder ID Number
....S ABSPCARD=$E(ABSPCARD,3,$L(ABSPCARD)) ;STRIP THE 2 CHARACTER QUALIFIER
....S ABSPGRP=$P($G(^ABSPC(ABSPCLMI,300)),U,1) ;TRANSACTION:CLAIM:Group Number
....S ABSPGRP=$E(ABSPGRP,3,$L(ABSPGRP)) ;STRIP THE 2 CHARACTER QUALIFIER
....S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM,ABSPPHM1)),U)+1
....S ^TMP($J,"ABSPCLMS",$P(ABSPIRMI,"."))="" ;OIT/CAS/RCS - Patch 46, S ABSPCLMS($P(ABSPIRMI,"."))=""
....S ABSPREAS(ABSPRNUM,ABSPPHM1)=ABSPRCNT_U_ABSPRNUM_":"_ABSPREA
....S ^TMP("ABSPOSRZ",$J,$P(ABSPRDT,"."),ABSPPHM1,ABSPTINS,ABSPRNUM,ABSPIRMI)=ABSPREA_U_$P(ABSPTL(ABSPTRNS,5),U,5)_U_$P(ABSPTL(ABSPTRNS,0),U,6)_U_$P(ABSPTL(ABSPTRNS,1),U,6)_U_ABSPCARD_U_ABSPGRP_U_ABSPCLMI
Q
NEXT ;WHAT TO DO NEXT
N ABSPSTOP,ABSPOUT
S (ABSPSTOP,ABSPOUT)=0
I $O(^TMP("ABSPOSRZ",$J,""))="" D
.D PRHDR
.W !!," NO REJECTIONS FOUND FOR THE SELECTED DATE(S)"
.D ZEND
.S ABSPSTOP=1
.Q
Q:ABSPSTOP
D SUM
D PRNTSUM
I ABSPOUT D ZEND Q
I ABSPRTYP["D" D PRNTDTL
D ZEND
Q
PRHDR ;PRINT HEADER
N ABSPFEDT,ABSPFBDT,Y
U IO W:$D(ABSPSUM) @IOF
S Y=ABSPSTRT
D DD^%DT
S ABSPFBDT=Y
S Y=$P(ABSPEND,".")
D DD^%DT
S ABSPFEDT=Y
W @IOF
W !,?19,"Pharmacy Point of Sale Rejection Report"
W !,?22,"Claims sorted by Rejection Reason"
W !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT
W !?30,"***SUMMARY REPORT***",!
Q
SUM ;PRINT SUMMARY PAGE AND TOTAL AMT PER EACH THAT WAS REJECTED
N ABSPPCNT,ABSPTMP
S ABSPSRDT=""
F S ABSPSRDT=$O(^TMP("ABSPOSRZ",$J,ABSPSRDT)) Q:ABSPSRDT="" D
.M ABSPTMP(ABSPSRDT)=^TMP("ABSPOSRZ",$J,ABSPSRDT)
.S ABSPSPHM=""
.F S ABSPSPHM=$O(ABSPTMP(ABSPSRDT,ABSPSPHM)) Q:ABSPSPHM="" D
..S ABSPSTIN=""
..F S ABSPSTIN=$O(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN)) Q:ABSPSTIN="" D
...S ABSPSRNM=""
...F S ABSPSRNM=$O(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM)) Q:ABSPSRNM="" D
....S ABSPSTTL=0,ABSPSRMI="",ABSPSTL1=0
....F S ABSPSRMI=$O(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI)) Q:ABSPSRMI="" D
.....S ABSPSREA=$P(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,1)
.....S ABSPPCNT=$P($G(ABSPREAS(""_ABSPSRNM_"",ABSPSPHM)),U)
.....S ABSPSTTL=ABSPSTTL+$P(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,2)
....S ABSPSTL1=ABSPSTTL+$P($G(ABSPSUM(ABSPSPHM,ABSPSRNM)),U,2)
....S ABSPSUM(ABSPSPHM,ABSPSRNM)=ABSPSRNM_":"_ABSPSREA_U_ABSPSTL1_U_ABSPSTIN_U_ABSPPCNT
.K ABSPTMP
Q
PRNTSUM ;PRINT THE SUMMARY REPORT
N ABSPGCNT,ABSPPCNT,ABSPSTOP,ABSPTMP
S ABSPSTOP=0
S ABSPPPHM=""
S ABSPRTOT=0
S ABSPPCNT=0
S ABSPGTOT=0
S ABSPGCNT=0
S ABSPBTOT=0
S ABSPSTOP=0
S ABSPQUIT=0
S ABSPOUT=0
D PRHDR
F S ABSPPPHM=$O(ABSPSUM(ABSPPPHM)) Q:(ABSPPPHM="")!(ABSPSTOP) D
.I ABSPOUT S ABSPSTOP=1 Q
.I ABSPPPHM=0 S ABSPPPHM=1
.S ABSPPHMN=$P(^ABSP(9002313.56,ABSPPPHM,0),U,1)
.;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen use paging.
.S ABSPOUT=$$WRITE^ABSPOSUU("!!,""PHARMACY: "",ABSPPHMN")
.Q:ABSPOUT
.S ABSPPRNM=""
.S ABSPRTOT=0
.S ABSPPCNT=0 ;IHS/OIT/SCR 110309 this is pharmacy count
.;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen use paging.
.S ABSPOUT=$$WRITE^ABSPOSUU("!?2,""REJECTION CODE: "",?58,"" TOTALED: "",?68,"" RX COUNT: """)
.Q:ABSPOUT
.F S ABSPPRNM=$O(ABSPSUM(ABSPPPHM,ABSPPRNM)) Q:(ABSPPRNM="")!(ABSPSTOP) D
..I ABSPOUT S ABSPSTOP=1 Q
..S ABSPDRTR=$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1)
..I ABSPDRTR'="" D
...;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
...S ABSPOUT=$$WRITE^ABSPOSUU("!?0,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1),?60,$J($FN($P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2),"","",2),7),?72,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)")
...Q:ABSPOUT
...S ABSPRTOT=ABSPRTOT+$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2)
...S ABSPPCNT=ABSPPCNT+$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)
..Q:ABSPOUT
.Q:ABSPSTOP
.Q:ABSPOUT
.S ABSPGTOT=ABSPGTOT+ABSPRTOT
.S ABSPGCNT=ABSPGCNT+ABSPPCNT
.;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen use paging
.W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR PHARMACY: $"",$FN(ABSPRTOT,"","",2)")
.Q:ABSPOUT
.W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED FOR PHARMACY: "",ABSPPCNT")
.Q:ABSPOUT
Q:ABSPSTOP
Q:ABSPOUT
;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: $"",$FN(ABSPGTOT,"","",2)")
Q:ABSPOUT
W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED: "",ABSPGCNT")
;W:$Y<3 ! W !!,"P - Preventable, N - Non-recoverable, B - Both"
Q
PRNTDHD ;PRINT DETAIL HEADER
I ABSPRTYP'["D" D ZEND Q
;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
S ABSPOUT=$$WRITE^ABSPOSUU("!!,?21,""********** Detailed Report **********"",!")
Q:ABSPOUT
S ABSPOUT=$$WRITE^ABSPOSUU("!,""CHT #"",?14,""NAME"",?32,""RX #/FILL # COBPayer"",?52,""INSURER"",?69,""AMT BILLED""")
Q:ABSPOUT
;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
S ABSPOUT=$$WRITE^ABSPOSUU("!,?3,""CARD HOLDER ID #"",?27,""GROUP #"",?40,""NDC #"",?60,""DRUG NAME""")
Q
PRNTDTL ;PRINT DETAILED REPORT
N ABSPCARD,ABSPFRDT,ABSPGRP,ABSPSTOP,ABSPNDC,ABSPDRNM,ABSPQUIT,ABSPOUT,NDCDRG,ABSPCLMI,Y,ABSPTMP
S ABSPPRDT=""
S ABSPPPHM=""
S ABSPPRNM=""
;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name on next two lines and New line above
S ABSPNDC=""
S ABSPDRNM=""
S ABSPRTOT=0
S ABSPGTOT=0
S ABSPRDTL=0
S ABSPSTOP=0
S ABSPQUIT=0
S ABSPOUT=0
F S ABSPPRDT=$O(^TMP("ABSPOSRZ",$J,ABSPPRDT)) Q:(ABSPPRDT="")!(ABSPQUIT)!(ABSPOUT) D
.N ABSPTMP
.M ABSPTMP(ABSPPRDT)=^TMP("ABSPOSRZ",$J,ABSPPRDT)
.S ABSPPPHM=""
.S Y=ABSPPRDT
.D DD^%DT
.S ABSPFRDT=Y ; FORMATTED RELEASE DATE
.S ABSPRDTL=0
.F S ABSPPPHM=$O(ABSPTMP(ABSPPRDT,ABSPPPHM)) Q:(ABSPPPHM="")!(ABSPOUT) D
..S ABSPPINS=""
..S ABSPPHMN=$P(^ABSP(9002313.56,ABSPPPHM,0),U,1)
..D PRNTDHD
..Q:ABSPOUT
..;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
..S ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""PHARMACY: "",ABSPPHMN,"" RELEASED DATE: "",ABSPFRDT")
..Q:ABSPOUT
..S ABSPBTOT=0
..F S ABSPPINS=$O(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS)) Q:(ABSPPINS="")!(ABSPOUT) D
...S ABSPPRNM=""
...F S ABSPPRNM=$O(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM)) Q:(ABSPPRNM="")!(ABSPOUT) D
....S ABSPPRMI=""
....S ABSPRJCD=$P($G(ABSPREAS(""_ABSPPRNM_"",ABSPPPHM)),U,2)
....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
....S ABSPOUT=$$WRITE^ABSPOSUU("!!,?15,""REJECTION CODE: "",$E(ABSPRJCD,1,48)")
....Q:ABSPOUT
....F S ABSPPRMI=$O(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI)) Q:(ABSPPRMI="")!(ABSPOUT) D
.....S (ABSPPCHT,ABSPPDIV,ABSPOPS)=""
.....S ABSPPTYP="P"
.....I $E($P(ABSPPRMI,".",2))=2 S ABSPPTYP="S"
.....I $E($P(ABSPPRMI,".",2))=3 S ABSPPTYP="T"
.....S ABSPPAT=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,3)
.....S ABSPCARD=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,5)
.....S ABSPGRP=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,6)
.....S ABSPPATN=$E($P(^DPT(ABSPPAT,0),U,1),1,20)
.....S ABSPOPS=$P($G(^ABSP(9002313.56,ABSPPPHM,"OPSITE",1,0)),U,1) ;OUTPATIENT SITE MIGHT NOT BE DEFINED
.....S:ABSPOPS'="" ABSPPDIV=$P($G(^PS(59,ABSPOPS,0)),U,6) ;NO OUTPATIENT SITE MEANS NO DIVISION
.....S:ABSPPDIV'="" ABSPPCHT=$P($G(^AUPNPAT(ABSPPAT,41,ABSPPDIV,0)),U,2) ;NO DIVISION MEANS NO CHART #
.....S ABSPPTP=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,2) ; PRICE
.....S ABSPINSN=$E($P($G(^AUTNINS(ABSPPINS,0)),U,1),1,22) ; INSURER NAME
.....S ABSPCLMI=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,7)
.....S ABSPPRX=$P(ABSPPRMI,".") ;INTERNAL RX #
.....S ABSPPRXR=$P($P(^ABSPC(ABSPCLMI,400,$P(^ABSPC(ABSPCLMI,400,0),U,3),400),U,3),"D3",2) ;Refill Number
.....;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name BEGIN
.....S NDCDRG=$$GTNDCDRG^ABSPOSUU(ABSPCLMI,ABSPPRX)
.....S ABSPNDC=$P(NDCDRG,U,1)
.....S ABSPDRNM=$P(NDCDRG,U,2)
.....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
.....S ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPPCHT,?9,ABSPPATN,?31,ABSPPRX_""/""_+ABSPPRXR_ABSPPTYP,?45,ABSPINSN,?70,""$""_$J(ABSPPTP,6,2)")
.....Q:ABSPOUT
.....;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
.....S ABSPOUT=$$WRITE^ABSPOSUU("!,?3,ABSPCARD,?27,ABSPGRP,?40,ABSPNDC,?60,ABSPDRNM")
.....Q:ABSPOUT
.....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
.....S ABSBPRTT=ABSPRTOT+ABSPPTP
.....S ABSPBTOT=ABSPPTP+ABSPBTOT
.....S ABSPRDTL=ABSPRDTL+ABSPPTP
...Q:ABSPOUT
..Q:ABSPOUT
..;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
..S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR "",ABSPPHMN,"": $"",$J($FN(ABSPBTOT,"","",2),6),!")
.Q:ABSPOUT
.;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
.S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR RELEASED DATE "",ABSPFRDT,"": $"",$J($FN(ABSPRDTL,"","",2),6)")
.Q:ABSPOUT
.S ABSPGTOT=ABSPGTOT+ABSPRDTL
Q:ABSPSTOP
Q:ABSPOUT
;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
I $D(ABSPRTYP) S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL AMOUNT REJECTED: $"",$J($FN(ABSPGTOT,"","",2),6),!!")
Q
ZEND ;END AND KILL VARIABLES
D ^%ZISC
K ^TMP("ABSPOSRZ",$J),^TMP($J,"ABSPCLMS"),ABSPTMP,ABSPSUM,ABSBPRTT,ABSPBTOT,ABSPGTOT,ABSPRTOT,ABSPINS,ABSPPTP,ABSPPAT,ABSPPCHT,ABSPINSN,ABSPPRX,ABSPPRMI,ABSPPRXR,ABSPPDIV,ABSPOPS,ABSPPATN,ABSPPPHM,ABSPPRDT
K ABSPREAS,ABSPRMI,ABSPSRDT,ABSPSTTL,ABSPSRMI,ABSPSPHM,ABSPSRNM,RNUM,ABSPSTIN,ABSPFBDT,ABSPFEDT,ABSPBDT,ABSPEDT,ABSPTINS,ABSPTRNS,ABSPJ,ABSPRTYP,ABSPDRT,ABSPDRTR,ABSPRJCD
K ABSPPHM1,ABSPPHMN,ABSPPINS,ABSPPRNM,ABSPRCD,ABSPRDTL,ABSPREA,ABSPSREA,ABSPSTL1,ABSPSTRT
Q
START ;
N X,Y,ABSPJ,ABSPRJC,ABSPPAT,ABSPPIEN
I $D(ZTQPARAM) D
.I $P(ZTQPARAM,";",1)["T-1" S ABSPSTRT=DT-1
.I $P(ZTQPARAM,";",2)["T-1" S ABSPEND=DT-1
.S ABSPINS="ALL"
.S ABSPPPHM="ALL"
.S ABSPRTYP="D"
.D FIND
.D ZEND
.Q
Q
ABSPOSRZ ;IHS/OIT/SCR - REJECTION REPORT BY REJECTION REASON
+1 ;;1.0;PHARMACY POINT OF SALE;**29,30,34,35,39,40,41,44,46**;JUN 21, 2001;Build 38
+2 ;IHS/OIT/CNI/RAN - Rewritten for patch 40 to run WITHOUT Report Master
+3 ;OIT/CAS/RCS - Fix report to look at only latest claim data not earlier claims, patch 44
+4 ;IHS/OIT/RCS - Fix program error when Reject code is not in table, patch 46
+5 ;IHS/OIT/RCS - Change ABSPCLMS variable to scratch file to fix STORE errors, patch 46
EN ; EP
+1 NEW ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT,ABSPREJ,ABSPRJ
+2 IF $DATA(ZTQPARAM)
DO START
+3 SET ABSPDONE=0
+4 SET ABSPQUIT=0
+5 FOR
IF ABSPDONE=1
QUIT
Begin DoDot:1
+6 SET ABSPSTRT=$$BDT^ABSPOSRU()
+7 IF ABSPSTRT=-1
Begin DoDot:2
+8 SET ABSPQUIT=1
+9 SET ABSPDONE=1
End DoDot:2
+10 IF ABSPQUIT
QUIT
+11 SET ABSPEND=$$EDT^ABSPOSRU()
+12 IF ABSPEND=-1
Begin DoDot:2
+13 SET ABSPQUIT=1
+14 SET ABSPDONE=1
+15 QUIT
End DoDot:2
+16 IF ABSPQUIT
QUIT
+17 IF ABSPSTRT<0
SET ABSPDONE=1
QUIT
+18 IF ABSPEND<0
SET ABSPDONE=1
QUIT
+19 SET X2=ABSPSTRT
SET X1=ABSPEND
DO ^%DTC
+20 IF X<0
DO EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")
+21 IF X>=0
SET ABSPDONE=1
+22 QUIT
End DoDot:1
+23 IF ABSPQUIT
QUIT
+24 SET ABSPQUIT=$$CLNC^ABSPOSRU()
+25 IF ABSPQUIT=-1
QUIT
+26 SET ABSPQUIT=$$INS^ABSPOSUU()
+27 IF ABSPQUIT=-1
QUIT
+28 ;IHS/OIT/SCR 092109 patch 34 - screen by selected reject code
SET ABSPQUIT=$$CODE^ABSPOSUU()
+29 IF ABSPQUIT=-1
QUIT
+30 SET ABSPQUIT=$$RTYPE()
+31 QUIT
RTYPE() ; SELECT IF YOU WANT SUMMARY, OR DETAILED
+1 NEW DIR,STARTIME,STOPTIME
+2 SET DIR(0)="S^S:SUMMARY;D:DETAILED"
+3 SET DIR("B")="D"
+4 SET DIR("A")="Please select S for Summary or D for Detailed"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
QUIT -1
+7 ; SET REPORT TYPE
SET ABSPRTYP=X
+8 DO DEVSEL^ABSPOSRU
+9 DO ^XBCLS
+10 SET STARTIME=$HOROLOG
+11 DO FIND
+12 SET STOPTIME=$HOROLOG
+13 SET ^TMP("ABSPOSRZ-RUNLOG",$JOB,STARTIME)=ABSPSTRT_"^"_$PIECE(ABSPEND,".")_"^"_($PIECE(STOPTIME,",",2)-$PIECE(STARTIME,",",2))
+14 DO NEXT
+15 QUIT 1
FIND ; FIND REJECTIONS BY RELEASE DATE "B" CROSS REFERENCE
+1 ;,ABSPCLMS
NEW ABSPDONE,ABSPRDT,ABSPCARD,ABSPGRP,ABSPCLMI,ABSPRCNT,ABSPRNUM,ABSPTRTM,ABSPRSMI,ABSPPRMI
+2 NEW ABSPTLTP,ABSPRESC,DO,ABSPIDTS,ABSPIDTE,ABSPIRMI,ABSPIRME
+3 ;IHS/OIT/SCR 082109 patch 34
NEW ABSPCODE,ABSPQUIT
+4 ;OIT/CAS/RCS 081213 Patch 46
KILL ^TMP($JOB,"ABSPCLMS")
+5 SET ABSPRDT=ABSPSTRT
+6 SET ABSPEND=ABSPEND_".99999999"
+7 SET ABSPDONE=0
+8 FOR
SET ABSPRDT=$ORDER(^PSRX("AL",ABSPRDT))
IF (ABSPRDT="")!(ABSPDONE)!(+ABSPRDT=0)
QUIT
Begin DoDot:1
+9 IF ABSPRDT>ABSPEND
SET ABSPDONE=1
QUIT
+10 SET ^TMP("ABSPOSRZ",$JOB,$PIECE(ABSPRDT,"."))=""
+11 SET ABSPPRMI=""
+12 FOR
SET ABSPPRMI=$ORDER(^PSRX("AL",ABSPRDT,ABSPPRMI))
IF ABSPPRMI=""
QUIT
Begin DoDot:2
+13 SET ABSPIRME=ABSPPRMI
+14 SET ABSPIRMI=ABSPPRMI_".99999999"
+15 FOR
SET ABSPIRMI=$ORDER(^ABSPTL("B",ABSPIRMI),-1)
IF (ABSPIRMI<ABSPIRME)!(ABSPIRMI="")
QUIT
Begin DoDot:3
+16 SET ABSPTRNS=""
+17 ;OIT/CAS/RCS 06202012 Patch 44 - Quit after the oldest/first claim is looked at, HEAT # 71102
FOR
SET ABSPTRNS=$ORDER(^ABSPTL("B",ABSPIRMI,ABSPTRNS),-1)
IF ABSPTRNS=""
QUIT
Begin DoDot:4
+18 NEW ABSPTL
+19 MERGE ABSPTL(ABSPTRNS)=^ABSPTL(ABSPTRNS)
+20 ;DONT REPORT CLOSED CLAIMS
+21 ;OIT/CAS/RCS - Patch 46, S ABSPCLMS($P(ABSPIRMI,"."))="" Q
IF +$PIECE($GET(ABSPTL(ABSPTRNS,9)),"^")
SET ^TMP($JOB,"ABSPCLMS",$PIECE(ABSPIRMI,"."))=""
QUIT
+22 SET ABSPTLTP=ABSPTL(ABSPTRNS,0)
+23 ;Response reference
SET ABSPRSMI=$PIECE(ABSPTLTP,U,5)
+24 ;Claim Reference
SET ABSPCLMI=$PIECE(ABSPTLTP,U,4)
+25 IF (ABSPRSMI="")!(ABSPCLMI="")
QUIT
+26 ;Position on claim(and response)
SET DO=$PIECE(ABSPTLTP,U,9)
+27 IF '$DATA(^ABSPR(ABSPRSMI,1000,DO))
SET DO=$$GETDO^ABSPOSUU(ABSPRSMI,$PIECE(ABSPIRMI,"."))
+28 IF DO=""
QUIT
+29 ;IHS/OIT/CASSEVERN/RAN 03/02/2011 patch 41 If there is a corrupted response just skip it rather than err out
+30 IF '$DATA(^ABSPR(ABSPRSMI,1000,DO,500))
QUIT
+31 ;OIT/CAS/RCS - Patch 46, S ABSPCLMS($P(ABSPIRMI,"."))="" ;We only care about rejects in this report
IF $PIECE(^ABSPR(ABSPRSMI,1000,DO,500),U)'="R"
SET ^TMP($JOB,"ABSPCLMS",$PIECE(ABSPIRMI,"."))=""
+32 ;OIT/CAS/RCS - Patch 46, Q:$D(ABSPCLMS($P(ABSPIRMI,".")))
IF $DATA(^TMP($JOB,"ABSPCLMS",$PIECE(ABSPIRMI,".")))
QUIT
+33 SET ABSPTINS=$PIECE(ABSPTL(ABSPTRNS,1),U,6)
+34 SET ABSPPHM1=""
+35 ;NOT SELECTED INSURER
IF ABSPINS'="ALL"
IF ABSPTINS'=ABSPINS
QUIT
+36 ;NOT SELECTED PHARMACY
IF (ABSPPPHM'="ALL")&&($PIECE(ABSPTL(ABSPTRNS,1),U,7)'=ABSPPPHM)
QUIT
+37 SET ABSPPHM1=ABSPPPHM
+38 ;SET PHARMACY
IF ABSPPPHM="ALL"
SET ABSPPHM1=$PIECE(ABSPTL(ABSPTRNS,1),U,7)
+39 IF ABSPPHM1=""
QUIT
+40 ;IHS/OIT/SCR 082109 START changes patch 34
+41 ;Added to skip junk data in PMAA test area
IF '$DATA(^ABSPR(ABSPRSMI,1000,DO,511))
SET (ABSPRNUM,ABSPREA)="UKN"
+42 ;IHS/OIT/RCS 080913 patch 46 If Reject code missing, create unkown Reject description
IF '$TEST
Begin DoDot:5
+43 SET ABSPRNUM=$PIECE(^ABSPR(ABSPRSMI,1000,DO,511,1,0),U)
+44 ;IHS/OIT/RCS PATCH 46
IF '$DATA(^ABSPF(9002313.93,"B",ABSPRNUM))
SET ABSPREA="Reject Code description not entered,See NCPDP Rejects"
QUIT
+45 SET ABSPREA=$PIECE(^ABSPF(9002313.93,$ORDER(^ABSPF(9002313.93,"B",ABSPRNUM,"")),0),U,2)
End DoDot:5
+46 IF (ABSPREJ'="ALL")&&(ABSPREJX'=ABSPRNUM)
SET ABSPQUIT=1
QUIT
+47 SET ABSPGRP=""
+48 SET ABSPCARD=""
+49 ;TRANSACTION:CLAIM:Cardholder ID Number
SET ABSPCARD=$PIECE($GET(^ABSPC(ABSPCLMI,300)),U,2)
+50 ;STRIP THE 2 CHARACTER QUALIFIER
SET ABSPCARD=$EXTRACT(ABSPCARD,3,$LENGTH(ABSPCARD))
+51 ;TRANSACTION:CLAIM:Group Number
SET ABSPGRP=$PIECE($GET(^ABSPC(ABSPCLMI,300)),U,1)
+52 ;STRIP THE 2 CHARACTER QUALIFIER
SET ABSPGRP=$EXTRACT(ABSPGRP,3,$LENGTH(ABSPGRP))
+53 SET ABSPRCNT=$PIECE($GET(ABSPREAS(ABSPRNUM,ABSPPHM1)),U)+1
+54 ;OIT/CAS/RCS - Patch 46, S ABSPCLMS($P(ABSPIRMI,"."))=""
SET ^TMP($JOB,"ABSPCLMS",$PIECE(ABSPIRMI,"."))=""
+55 SET ABSPREAS(ABSPRNUM,ABSPPHM1)=ABSPRCNT_U_ABSPRNUM_":"_ABSPREA
+56 SET ^TMP("ABSPOSRZ",$JOB,$PIECE(ABSPRDT,"."),ABSPPHM1,ABSPTINS,ABSPRNUM,ABSPIRMI)=ABSPREA_U_$PIECE(ABSPTL(ABSPTRNS,5),U,5)_U_$PIECE(ABSPTL(ABSPTRNS,0),U,6)_U_$PIECE(ABSPTL(ABSPTRNS,1),U,6)_U_ABSPCARD_U_ABSPGRP_U_
ABSPCLMI
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+57 QUIT
NEXT ;WHAT TO DO NEXT
+1 NEW ABSPSTOP,ABSPOUT
+2 SET (ABSPSTOP,ABSPOUT)=0
+3 IF $ORDER(^TMP("ABSPOSRZ",$JOB,""))=""
Begin DoDot:1
+4 DO PRHDR
+5 WRITE !!," NO REJECTIONS FOUND FOR THE SELECTED DATE(S)"
+6 DO ZEND
+7 SET ABSPSTOP=1
+8 QUIT
End DoDot:1
+9 IF ABSPSTOP
QUIT
+10 DO SUM
+11 DO PRNTSUM
+12 IF ABSPOUT
DO ZEND
QUIT
+13 IF ABSPRTYP["D"
DO PRNTDTL
+14 DO ZEND
+15 QUIT
PRHDR ;PRINT HEADER
+1 NEW ABSPFEDT,ABSPFBDT,Y
+2 USE IO
IF $DATA(ABSPSUM)
WRITE @IOF
+3 SET Y=ABSPSTRT
+4 DO DD^%DT
+5 SET ABSPFBDT=Y
+6 SET Y=$PIECE(ABSPEND,".")
+7 DO DD^%DT
+8 SET ABSPFEDT=Y
+9 WRITE @IOF
+10 WRITE !,?19,"Pharmacy Point of Sale Rejection Report"
+11 WRITE !,?22,"Claims sorted by Rejection Reason"
+12 WRITE !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT
+13 WRITE !?30,"***SUMMARY REPORT***",!
+14 QUIT
SUM ;PRINT SUMMARY PAGE AND TOTAL AMT PER EACH THAT WAS REJECTED
+1 NEW ABSPPCNT,ABSPTMP
+2 SET ABSPSRDT=""
+3 FOR
SET ABSPSRDT=$ORDER(^TMP("ABSPOSRZ",$JOB,ABSPSRDT))
IF ABSPSRDT=""
QUIT
Begin DoDot:1
+4 MERGE ABSPTMP(ABSPSRDT)=^TMP("ABSPOSRZ",$JOB,ABSPSRDT)
+5 SET ABSPSPHM=""
+6 FOR
SET ABSPSPHM=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM))
IF ABSPSPHM=""
QUIT
Begin DoDot:2
+7 SET ABSPSTIN=""
+8 FOR
SET ABSPSTIN=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN))
IF ABSPSTIN=""
QUIT
Begin DoDot:3
+9 SET ABSPSRNM=""
+10 FOR
SET ABSPSRNM=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM))
IF ABSPSRNM=""
QUIT
Begin DoDot:4
+11 SET ABSPSTTL=0
SET ABSPSRMI=""
SET ABSPSTL1=0
+12 FOR
SET ABSPSRMI=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI))
IF ABSPSRMI=""
QUIT
Begin DoDot:5
+13 SET ABSPSREA=$PIECE(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,1)
+14 SET ABSPPCNT=$PIECE($GET(ABSPREAS(""_ABSPSRNM_"",ABSPSPHM)),U)
+15 SET ABSPSTTL=ABSPSTTL+$PIECE(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,2)
End DoDot:5
+16 SET ABSPSTL1=ABSPSTTL+$PIECE($GET(ABSPSUM(ABSPSPHM,ABSPSRNM)),U,2)
+17 SET ABSPSUM(ABSPSPHM,ABSPSRNM)=ABSPSRNM_":"_ABSPSREA_U_ABSPSTL1_U_ABSPSTIN_U_ABSPPCNT
End DoDot:4
End DoDot:3
End DoDot:2
+18 KILL ABSPTMP
End DoDot:1
+19 QUIT
PRNTSUM ;PRINT THE SUMMARY REPORT
+1 NEW ABSPGCNT,ABSPPCNT,ABSPSTOP,ABSPTMP
+2 SET ABSPSTOP=0
+3 SET ABSPPPHM=""
+4 SET ABSPRTOT=0
+5 SET ABSPPCNT=0
+6 SET ABSPGTOT=0
+7 SET ABSPGCNT=0
+8 SET ABSPBTOT=0
+9 SET ABSPSTOP=0
+10 SET ABSPQUIT=0
+11 SET ABSPOUT=0
+12 DO PRHDR
+13 FOR
SET ABSPPPHM=$ORDER(ABSPSUM(ABSPPPHM))
IF (ABSPPPHM="")!(ABSPSTOP)
QUIT
Begin DoDot:1
+14 IF ABSPOUT
SET ABSPSTOP=1
QUIT
+15 IF ABSPPPHM=0
SET ABSPPPHM=1
+16 SET ABSPPHMN=$PIECE(^ABSP(9002313.56,ABSPPPHM,0),U,1)
+17 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen use paging.
+18 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""PHARMACY: "",ABSPPHMN")
+19 IF ABSPOUT
QUIT
+20 SET ABSPPRNM=""
+21 SET ABSPRTOT=0
+22 ;IHS/OIT/SCR 110309 this is pharmacy count
SET ABSPPCNT=0
+23 ;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen use paging.
+24 SET ABSPOUT=$$WRITE^ABSPOSUU("!?2,""REJECTION CODE: "",?58,"" TOTALED: "",?68,"" RX COUNT: """)
+25 IF ABSPOUT
QUIT
+26 FOR
SET ABSPPRNM=$ORDER(ABSPSUM(ABSPPPHM,ABSPPRNM))
IF (ABSPPRNM="")!(ABSPSTOP)
QUIT
Begin DoDot:2
+27 IF ABSPOUT
SET ABSPSTOP=1
QUIT
+28 SET ABSPDRTR=$PIECE(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1)
+29 IF ABSPDRTR'=""
Begin DoDot:3
+30 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
+31 SET ABSPOUT=$$WRITE^ABSPOSUU("!?0,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1),?60,$J($FN($P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2),"","",2),7),?72,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)")
+32 IF ABSPOUT
QUIT
+33 SET ABSPRTOT=ABSPRTOT+$PIECE(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2)
+34 SET ABSPPCNT=ABSPPCNT+$PIECE(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)
End DoDot:3
+35 IF ABSPOUT
QUIT
End DoDot:2
+36 IF ABSPSTOP
QUIT
+37 IF ABSPOUT
QUIT
+38 SET ABSPGTOT=ABSPGTOT+ABSPRTOT
+39 SET ABSPGCNT=ABSPGCNT+ABSPPCNT
+40 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen use paging
+41 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR PHARMACY: $"",$FN(ABSPRTOT,"","",2)")
+42 IF ABSPOUT
QUIT
+43 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED FOR PHARMACY: "",ABSPPCNT")
+44 IF ABSPOUT
QUIT
End DoDot:1
+45 IF ABSPSTOP
QUIT
+46 IF ABSPOUT
QUIT
+47 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+48 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: $"",$FN(ABSPGTOT,"","",2)")
+49 IF ABSPOUT
QUIT
+50 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED: "",ABSPGCNT")
+51 ;W:$Y<3 ! W !!,"P - Preventable, N - Non-recoverable, B - Both"
+52 QUIT
PRNTDHD ;PRINT DETAIL HEADER
+1 IF ABSPRTYP'["D"
DO ZEND
QUIT
+2 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+3 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?21,""********** Detailed Report **********"",!")
+4 IF ABSPOUT
QUIT
+5 SET ABSPOUT=$$WRITE^ABSPOSUU("!,""CHT #"",?14,""NAME"",?32,""RX #/FILL # COBPayer"",?52,""INSURER"",?69,""AMT BILLED""")
+6 IF ABSPOUT
QUIT
+7 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
+8 SET ABSPOUT=$$WRITE^ABSPOSUU("!,?3,""CARD HOLDER ID #"",?27,""GROUP #"",?40,""NDC #"",?60,""DRUG NAME""")
+9 QUIT
PRNTDTL ;PRINT DETAILED REPORT
+1 NEW ABSPCARD,ABSPFRDT,ABSPGRP,ABSPSTOP,ABSPNDC,ABSPDRNM,ABSPQUIT,ABSPOUT,NDCDRG,ABSPCLMI,Y,ABSPTMP
+2 SET ABSPPRDT=""
+3 SET ABSPPPHM=""
+4 SET ABSPPRNM=""
+5 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name on next two lines and New line above
+6 SET ABSPNDC=""
+7 SET ABSPDRNM=""
+8 SET ABSPRTOT=0
+9 SET ABSPGTOT=0
+10 SET ABSPRDTL=0
+11 SET ABSPSTOP=0
+12 SET ABSPQUIT=0
+13 SET ABSPOUT=0
+14 FOR
SET ABSPPRDT=$ORDER(^TMP("ABSPOSRZ",$JOB,ABSPPRDT))
IF (ABSPPRDT="")!(ABSPQUIT)!(ABSPOUT)
QUIT
Begin DoDot:1
+15 NEW ABSPTMP
+16 MERGE ABSPTMP(ABSPPRDT)=^TMP("ABSPOSRZ",$JOB,ABSPPRDT)
+17 SET ABSPPPHM=""
+18 SET Y=ABSPPRDT
+19 DO DD^%DT
+20 ; FORMATTED RELEASE DATE
SET ABSPFRDT=Y
+21 SET ABSPRDTL=0
+22 FOR
SET ABSPPPHM=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM))
IF (ABSPPPHM="")!(ABSPOUT)
QUIT
Begin DoDot:2
+23 SET ABSPPINS=""
+24 SET ABSPPHMN=$PIECE(^ABSP(9002313.56,ABSPPPHM,0),U,1)
+25 DO PRNTDHD
+26 IF ABSPOUT
QUIT
+27 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+28 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""PHARMACY: "",ABSPPHMN,"" RELEASED DATE: "",ABSPFRDT")
+29 IF ABSPOUT
QUIT
+30 SET ABSPBTOT=0
+31 FOR
SET ABSPPINS=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS))
IF (ABSPPINS="")!(ABSPOUT)
QUIT
Begin DoDot:3
+32 SET ABSPPRNM=""
+33 FOR
SET ABSPPRNM=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM))
IF (ABSPPRNM="")!(ABSPOUT)
QUIT
Begin DoDot:4
+34 SET ABSPPRMI=""
+35 SET ABSPRJCD=$PIECE($GET(ABSPREAS(""_ABSPPRNM_"",ABSPPPHM)),U,2)
+36 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+37 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?15,""REJECTION CODE: "",$E(ABSPRJCD,1,48)")
+38 IF ABSPOUT
QUIT
+39 FOR
SET ABSPPRMI=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI))
IF (ABSPPRMI="")!(ABSPOUT)
QUIT
Begin DoDot:5
+40 SET (ABSPPCHT,ABSPPDIV,ABSPOPS)=""
+41 SET ABSPPTYP="P"
+42 IF $EXTRACT($PIECE(ABSPPRMI,".",2))=2
SET ABSPPTYP="S"
+43 IF $EXTRACT($PIECE(ABSPPRMI,".",2))=3
SET ABSPPTYP="T"
+44 SET ABSPPAT=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,3)
+45 SET ABSPCARD=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,5)
+46 SET ABSPGRP=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,6)
+47 SET ABSPPATN=$EXTRACT($PIECE(^DPT(ABSPPAT,0),U,1),1,20)
+48 ;OUTPATIENT SITE MIGHT NOT BE DEFINED
SET ABSPOPS=$PIECE($GET(^ABSP(9002313.56,ABSPPPHM,"OPSITE",1,0)),U,1)
+49 ;NO OUTPATIENT SITE MEANS NO DIVISION
IF ABSPOPS'=""
SET ABSPPDIV=$PIECE($GET(^PS(59,ABSPOPS,0)),U,6)
+50 ;NO DIVISION MEANS NO CHART #
IF ABSPPDIV'=""
SET ABSPPCHT=$PIECE($GET(^AUPNPAT(ABSPPAT,41,ABSPPDIV,0)),U,2)
+51 ; PRICE
SET ABSPPTP=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,2)
+52 ; INSURER NAME
SET ABSPINSN=$EXTRACT($PIECE($GET(^AUTNINS(ABSPPINS,0)),U,1),1,22)
+53 SET ABSPCLMI=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,7)
+54 ;INTERNAL RX #
SET ABSPPRX=$PIECE(ABSPPRMI,".")
+55 ;Refill Number
SET ABSPPRXR=$PIECE($PIECE(^ABSPC(ABSPCLMI,400,$PIECE(^ABSPC(ABSPCLMI,400,0),U,3),400),U,3),"D3",2)
+56 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name BEGIN
+57 SET NDCDRG=$$GTNDCDRG^ABSPOSUU(ABSPCLMI,ABSPPRX)
+58 SET ABSPNDC=$PIECE(NDCDRG,U,1)
+59 SET ABSPDRNM=$PIECE(NDCDRG,U,2)
+60 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+61 SET ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPPCHT,?9,ABSPPATN,?31,ABSPPRX_""/""_+ABSPPRXR_ABSPPTYP,?45,ABSPINSN,?70,""$""_$J(ABSPPTP,6,2)")
+62 IF ABSPOUT
QUIT
+63 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
+64 SET ABSPOUT=$$WRITE^ABSPOSUU("!,?3,ABSPCARD,?27,ABSPGRP,?40,ABSPNDC,?60,ABSPDRNM")
+65 IF ABSPOUT
QUIT
+66 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
+67 SET ABSBPRTT=ABSPRTOT+ABSPPTP
+68 SET ABSPBTOT=ABSPPTP+ABSPBTOT
+69 SET ABSPRDTL=ABSPRDTL+ABSPPTP
End DoDot:5
End DoDot:4
+70 IF ABSPOUT
QUIT
End DoDot:3
+71 IF ABSPOUT
QUIT
+72 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+73 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR "",ABSPPHMN,"": $"",$J($FN(ABSPBTOT,"","",2),6),!")
End DoDot:2
+74 IF ABSPOUT
QUIT
+75 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+76 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR RELEASED DATE "",ABSPFRDT,"": $"",$J($FN(ABSPRDTL,"","",2),6)")
+77 IF ABSPOUT
QUIT
+78 SET ABSPGTOT=ABSPGTOT+ABSPRDTL
End DoDot:1
+79 IF ABSPSTOP
QUIT
+80 IF ABSPOUT
QUIT
+81 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+82 IF $DATA(ABSPRTYP)
SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL AMOUNT REJECTED: $"",$J($FN(ABSPGTOT,"","",2),6),!!")
+83 QUIT
ZEND ;END AND KILL VARIABLES
+1 DO ^%ZISC
+2 KILL ^TMP("ABSPOSRZ",$JOB),^TMP($JOB,"ABSPCLMS"),ABSPTMP,ABSPSUM,ABSBPRTT,ABSPBTOT,ABSPGTOT,ABSPRTOT,ABSPINS,ABSPPTP,ABSPPAT,ABSPPCHT,ABSPINSN,ABSPPRX,ABSPPRMI,ABSPPRXR,ABSPPDIV,ABSPOPS,ABSPPATN,ABSPPPHM,ABSPPRDT
+3 KILL ABSPREAS,ABSPRMI,ABSPSRDT,ABSPSTTL,ABSPSRMI,ABSPSPHM,ABSPSRNM,RNUM,ABSPSTIN,ABSPFBDT,ABSPFEDT,ABSPBDT,ABSPEDT,ABSPTINS,ABSPTRNS,ABSPJ,ABSPRTYP,ABSPDRT,ABSPDRTR,ABSPRJCD
+4 KILL ABSPPHM1,ABSPPHMN,ABSPPINS,ABSPPRNM,ABSPRCD,ABSPRDTL,ABSPREA,ABSPSREA,ABSPSTL1,ABSPSTRT
+5 QUIT
START ;
+1 NEW X,Y,ABSPJ,ABSPRJC,ABSPPAT,ABSPPIEN
+2 IF $DATA(ZTQPARAM)
Begin DoDot:1
+3 IF $PIECE(ZTQPARAM,";",1)["T-1"
SET ABSPSTRT=DT-1
+4 IF $PIECE(ZTQPARAM,";",2)["T-1"
SET ABSPEND=DT-1
+5 SET ABSPINS="ALL"
+6 SET ABSPPPHM="ALL"
+7 SET ABSPRTYP="D"
+8 DO FIND
+9 DO ZEND
+10 QUIT
End DoDot:1
+11 QUIT
