ABSPOSR5 ;IHS/OIT/SCR - REJECTION REPORT BY REJECTION REASON
;;1.0;PHARMACY POINT OF SALE;**29,30,34,35,39,40**;JUN 21, 2001;Build 38
; DISPLAYS POS CLAIMS BY REJECT CODE
; PATCH 40 NOTES: This routine was removed from POS MENUs and replaced with routine ABSPOSRY which does not use
; ABSP REPORT MASTER file or the ^ABSPT("NON-FILEMAN" cross-reference. It is staying with the build for comparison
;
UPD ; UPDATE THE REPORT MASTER FILE IN ABSP
N ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT
;D AUTO^ABSPOSM1() ;IHS/OIT/CNI/SCR patch 40 - can't run this from the prompt
I $D(ZTQPARAM) D START
S ABSPDONE=0
S ABSPQUIT=0
F Q:ABSPDONE=1 D
.S ABSPSTRT=$$BDT()
.I ABSPSTRT=-1 D
..S ABSPQUIT=1
..S ABSPDONE=1
.Q:ABSPQUIT
.S ABSPEND=$$EDT()
.I ABSPEND=-1 D
..S ABSPQUIT=1
..S ABSPDONE=1
.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:ABSPQUIT
S ABSPQUIT=$$CLNC()
Q:ABSPQUIT=-1
S ABSPQUIT=$$INS()
Q:ABSPQUIT=-1
S ABSPQUIT=$$CODE() ;IHS/OIT/SCR 092109 patch 34 - screen by selected reject code
Q:ABSPQUIT=-1
S ABSPQUIT=$$RTYPE()
Q
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
N DIC,X,Y
S DIC="^ABSP(9002313.56,"
S DIC(0)="AEMQVZ"
S DIC("A")="Please Select a Pharmacy or leave blank for ALL: "
D ^DIC K DIC
I X["^" Q -1
I Y=-1 S ABSPPPHM="ALL"
I Y>-1 S ABSPPPHM=$P(Y,"^",1),ABSPPHMN=$P(Y,"^",2)
Q 1
INS() ; SELECT THE INSURER OR CHOOSE ALL INSURERS
N DIC,X,Y
S DIC="^ABSPEI("
S DIC(0)="AEMNQZ"
S DIC("A")="Please choose an insurer or leave blank for ALL POS electronic insurers: "
D ^DIC K DIC
I X["^" Q -1
I Y=-1 S ABSPINS="ALL"
I Y'=-1 S ABSPINS=$P(Y,"^",1),ABSPINSN=$P(Y,"^",2)
Q 1
CODE() ;SELECT THE REJECTION CODE OR CHOOSE ALL CODES
;IHS/OIT/SCR 082109 START changes patch 34
N DIC,X,Y
S DIC="^ABSPRJC("
S DIC(0)="AEMNQZ"
S DIC("A")="Please choose a REJECTION CODE or leave blank for ALL: "
D ^DIC K DIC
I X["^" Q -1
I Y=-1 S ABSPREJ="ALL"
I Y'=-1 S ABSPREJ=$P(Y,"^",1),ABSPREJX=$P(Y,"^",2)
Q 1
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
D ^XBCLS
S STARTIME=$H
D FIND
S STOPTIME=$H
S ^TMP("ABSPOSR5-RUNLOG",$J,STARTIME)=ABSPSTRT_"^"_$P(ABSPEND,".")_"^"_($P(STOPTIME,",",2)-$P(STARTIME,",",2)) ;IHS/OIT/CNI/RAN patch 40 081810 for benchmark
D NEXT
Q 1
DEVSEL ; SELECT DEVICE
N ABSPSTOP
S ABSPSTOP=0
D ^%ZIS
I POP D
.D ^%ZIS
I $D(DUOUT) D
.D ZEND
.S ABSPSTOP=1
Q:ABSPSTOP
I POP D
.W "DEVICE UNAVAILABLE" G DEVSEL
Q
FIND ; FIND REJECTIONS BY RELEASE DATE "B" CROSS REFERENCE
N ABSPDONE,ABSPRDT,ABSPCARD,ABSPGRP,ABSPCLMI,ABSPRCNT,ABSPRNUM
N ABSPCODE,ABSPQUIT ;IHS/OIT/SCR 082109 patch 34
S ABSPRDT=ABSPSTRT-1
S ABSPDONE=0
S ABSPRMI=""
F S ABSPRDT=$O(^ABSPECX("RPT","B",ABSPRDT)) Q:ABSPRDT=""!ABSPDONE D
.I ABSPRDT>ABSPEND S ABSPDONE=1 Q
.S ABSPTMP(ABSPRDT)=""
.F ABSPJ=1:1 S ABSPRMI=$O(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI)) Q:ABSPRMI'=+ABSPRMI D
..S ABSPQUIT=0
..I $P(^ABSPECX("RPT",ABSPRMI,0),U,6)'=1 Q ; NOT A REJECTED CLAIM
..S ABSPTRNS=$P(^ABSPECX("RPT",ABSPRMI,0),U,3),ABSPTINS=$P(^ABSPTL(ABSPTRNS,1),U,6)
..S ABSPPHM1=""
..I ABSPINS'="ALL" Q:ABSPTINS'=ABSPINS ; NOT SELECTED INSURER
..I ABSPPPHM'="ALL" D
...I $P(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPPHM Q ; NOT SELECTED PHARMACY
...S ABSPPHM1=ABSPPPHM
...Q
..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 ABSPREJ'="ALL" D ;QUIT IF NOT SELECTED REJECT CODE
...I $D(^ABSPECX("RPT",ABSPRMI,"R",0)) D
....S ABSPREA=$P($G(^ABSPECX("RPT",ABSPRMI,"R",1,0)),U,1)
....S ABSPNUM=$P(ABSPREA,":",1)
...I ABSPREJX'=ABSPNUM S ABSPQUIT=1
...Q
..Q:ABSPQUIT
..;IHS/OIT/SCR 082109 END changes patch 34
..I $D(^ABSPECX("RPT",ABSPRMI,"R",0)) D
...S ABSPREA=$P(^ABSPECX("RPT",ABSPRMI,"R",1,0),U,1)
...S ABSPRNUM=$P(ABSPREA,":",1)
...S ABSPRCD="R"
...Q
..I '$D(^ABSPECX("RPT",ABSPRMI,"R",0)) D
...S ABSPREA=$P($G(^ABSPECX("RPT",ABSPRMI,"M",1,0)),U,1)
...S:ABSPREA="" ABSPREA="UKN"
...S ABSPRNUM="999"
...S ABSPRCD="M" ; GET reason
...Q
..S ABSPCLMI=$P(^ABSPTL(ABSPTRNS,0),"^",4)
..S ABSPGRP=""
..S ABSPCARD=""
..I ABSPCLMI'="" D
...S ABSPCARD=$P($G(^ABSPC(ABSPCLMI,300)),"^",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)),"^",1) ;TRANSACTION:CLAIM:Group Number
...S ABSPGRP=$E(ABSPGRP,3,$L(ABSPGRP)) ;STRIP THE 2 CHARACTER QUALIFIER
..;S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM)),"^",1)+1
..S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM,ABSPPHM1)),"^",1)+1 ;IHS/OIT/SCR 110309 patch 35
..;S ABSPREAS(ABSPRNUM)=ABSPRCNT_"^"_ABSPREA ;COUNT OF REJECT REASON TYPE^REJECT REASON
..S ABSPREAS(ABSPRNUM,ABSPPHM1)=ABSPRCNT_"^"_ABSPREA ;IHS/OIT/SCR 110309 patch 35
..S ABSPTMP(ABSPRDT,ABSPPHM1,ABSPTINS,ABSPRNUM,ABSPRMI)=ABSPREA_"^"_$P(^ABSPTL(ABSPTRNS,5),U,5)_"^"_$P(^ABSPTL(ABSPTRNS,0),U,6)_"^"_$P(^ABSPTL(ABSPTRNS,1),U,6)_"^"_ABSPCARD_"^"_ABSPGRP
Q
NEXT ; WHAT TO DO NEXT
N ABSPSTOP,ABSPOUT
S (ABSPSTOP,ABSPOUT)=0
I $O(ABSPTMP(""))="" 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
U IO W:$D(ABSPSUM) @IOF
S Y=ABSPSTRT
D DD^%DT
S ABSPFBDT=Y
S Y=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
; TOTAL COUNTS BY REJECT CODE (1ST ON LIST)
; AND TOTAL AMT PER EACH THAT WAS REJECTED
N ABSPPCNT
S ABSPSRDT=""
F S ABSPSRDT=$O(ABSPTMP(ABSPSRDT)) Q:ABSPSRDT="" D
.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(ABSPREAS(""_ABSPSRNM_""),U,1) ; GET COUNT OF THIS REJECTION REASON
.....S ABSPPCNT=$P(ABSPREAS(""_ABSPSRNM_"",ABSPSPHM),U,1) ;IHS/OIT/SCR 110309 patch 35
.....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)=ABSPSREA_"^"_ABSPSTL1_"^"_ABSPSTIN_"^"_ABSPPCNT
Q
PRNTSUM ; PRINT THE SUMMARY REPORT
N ABSPGCNT,ABSPPCNT,ABSPSTOP
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
.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($P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2),7,2),?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: $"",ABSPRTOT")
.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: $"",ABSPGTOT")
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 #"",?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
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(ABSPTMP(ABSPPRDT)) Q:(ABSPPRDT="")!(ABSPQUIT)!(ABSPOUT) D
.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(ABSPREAS(""_ABSPPRNM_"",ABSPPPHM),U,2) ;IHS/OIT/SCR 111309 patch 35
....;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 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 ABSPPRX=$P(^ABSPECX("RPT",ABSPPRMI,0),U,4)
.....S ABSPPRXR=$P($G(^ABSPECX("RPT",ABSPPRMI,0)),U,5) ; SET INTERNAL RX # AND REFILL #
.....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
.....;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name BEGIN
.....N ABSPTRNS,ABSPCLMI
.....S ABSPTRNS=$P($G(^ABSPECX("RPT",ABSPPRMI,0)),"^",3)
.....S ABSPCLMI=$P($G(^ABSPTL(ABSPTRNS,0)),"^",4)
.....S NDCDRG=$$GTNDCDRG^ABSPOSUU(ABSPCLMI,ABSPPRX)
.....S ABSPNDC=$P(NDCDRG,"^",1)
.....S ABSPDRNM=$P(NDCDRG,"^",2)
.....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
.....S ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPPCHT,?9,ABSPPATN,?31,ABSPPRX_""/""_ABSPPRXR,?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(ABSPBTOT,6,2),!")
.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(ABSPRDTL,6,2)")
.Q:ABSPOUT
.S ABSPGTOT=ABSPGTOT+ABSPRDTL
Q:ABSPSTOP
Q:ABSPOUT
;I $D(ABSPRTYP) W !!,"TOTAL AMOUNT REJECTED: ",ABSBPRTT,!!,"P - Preventable, N - Non-recoverable, B - Both"
;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
I $D(ABSPRTYP) S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL AMOUNT REJECTED: $"",$J(ABSPGTOT,6,2),!!")
Q
ZEND ; END AND KILL VARIABLES
D ^%ZISC
K 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
BDT() ; ENTER BEGINING DATE
N ABSPBDT,DIR,X1,X
W !
K DIR
S DIR(0)="DEX"
S DIR("A")="Enter Beginning Prescription Release Date"
D ^DIR
I $D(DIRUT) Q -1
S ABSPBDT=+Y
S X1=ABSPBDT D C^%DTC
Q X
EDT() ; ENTER END DATE
N ABSPEDT,DIR,X1,X
W !
K DIR
S DIR(0)="DEX"
S DIR("A")="Enter Ending Prescription Release Date"
D ^DIR
I $D(DIRUT) Q -1
S ABSPEDT=+Y
S X1=ABSPEDT D C^%DTC
Q X
ABSPOSR5 ;IHS/OIT/SCR - REJECTION REPORT BY REJECTION REASON
+1 ;;1.0;PHARMACY POINT OF SALE;**29,30,34,35,39,40**;JUN 21, 2001;Build 38
+2 ; DISPLAYS POS CLAIMS BY REJECT CODE
+3 ; PATCH 40 NOTES: This routine was removed from POS MENUs and replaced with routine ABSPOSRY which does not use
+4 ; ABSP REPORT MASTER file or the ^ABSPT("NON-FILEMAN" cross-reference. It is staying with the build for comparison
+5 ;
UPD ; UPDATE THE REPORT MASTER FILE IN ABSP
+1 NEW ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT
+2 ;D AUTO^ABSPOSM1() ;IHS/OIT/CNI/SCR patch 40 - can't run this from the prompt
+3 IF $DATA(ZTQPARAM)
DO START
+4 SET ABSPDONE=0
+5 SET ABSPQUIT=0
+6 FOR
IF ABSPDONE=1
QUIT
Begin DoDot:1
+7 SET ABSPSTRT=$$BDT()
+8 IF ABSPSTRT=-1
Begin DoDot:2
+9 SET ABSPQUIT=1
+10 SET ABSPDONE=1
End DoDot:2
+11 IF ABSPQUIT
QUIT
+12 SET ABSPEND=$$EDT()
+13 IF ABSPEND=-1
Begin DoDot:2
+14 SET ABSPQUIT=1
+15 SET ABSPDONE=1
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
End DoDot:1
+22 IF ABSPQUIT
QUIT
+23 SET ABSPQUIT=$$CLNC()
+24 IF ABSPQUIT=-1
QUIT
+25 SET ABSPQUIT=$$INS()
+26 IF ABSPQUIT=-1
QUIT
+27 ;IHS/OIT/SCR 092109 patch 34 - screen by selected reject code
SET ABSPQUIT=$$CODE()
+28 IF ABSPQUIT=-1
QUIT
+29 SET ABSPQUIT=$$RTYPE()
+30 QUIT
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
+1 NEW DIC,X,Y
+2 SET DIC="^ABSP(9002313.56,"
+3 SET DIC(0)="AEMQVZ"
+4 SET DIC("A")="Please Select a Pharmacy or leave blank for ALL: "
+5 DO ^DIC
KILL DIC
+6 IF X["^"
QUIT -1
+7 IF Y=-1
SET ABSPPPHM="ALL"
+8 IF Y>-1
SET ABSPPPHM=$PIECE(Y,"^",1)
SET ABSPPHMN=$PIECE(Y,"^",2)
+9 QUIT 1
INS() ; SELECT THE INSURER OR CHOOSE ALL INSURERS
+1 NEW DIC,X,Y
+2 SET DIC="^ABSPEI("
+3 SET DIC(0)="AEMNQZ"
+4 SET DIC("A")="Please choose an insurer or leave blank for ALL POS electronic insurers: "
+5 DO ^DIC
KILL DIC
+6 IF X["^"
QUIT -1
+7 IF Y=-1
SET ABSPINS="ALL"
+8 IF Y'=-1
SET ABSPINS=$PIECE(Y,"^",1)
SET ABSPINSN=$PIECE(Y,"^",2)
+9 QUIT 1
CODE() ;SELECT THE REJECTION CODE OR CHOOSE ALL CODES
+1 ;IHS/OIT/SCR 082109 START changes patch 34
+2 NEW DIC,X,Y
+3 SET DIC="^ABSPRJC("
+4 SET DIC(0)="AEMNQZ"
+5 SET DIC("A")="Please choose a REJECTION CODE or leave blank for ALL: "
+6 DO ^DIC
KILL DIC
+7 IF X["^"
QUIT -1
+8 IF Y=-1
SET ABSPREJ="ALL"
+9 IF Y'=-1
SET ABSPREJ=$PIECE(Y,"^",1)
SET ABSPREJX=$PIECE(Y,"^",2)
+10 QUIT 1
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
+9 DO ^XBCLS
+10 SET STARTIME=$HOROLOG
+11 DO FIND
+12 SET STOPTIME=$HOROLOG
+13 ;IHS/OIT/CNI/RAN patch 40 081810 for benchmark
SET ^TMP("ABSPOSR5-RUNLOG",$JOB,STARTIME)=ABSPSTRT_"^"_$PIECE(ABSPEND,".")_"^"_($PIECE(STOPTIME,",",2)-$PIECE(STARTIME,",",2))
+14 DO NEXT
+15 QUIT 1
DEVSEL ; SELECT DEVICE
+1 NEW ABSPSTOP
+2 SET ABSPSTOP=0
+3 DO ^%ZIS
+4 IF POP
Begin DoDot:1
+5 DO ^%ZIS
End DoDot:1
+6 IF $DATA(DUOUT)
Begin DoDot:1
+7 DO ZEND
+8 SET ABSPSTOP=1
End DoDot:1
+9 IF ABSPSTOP
QUIT
+10 IF POP
Begin DoDot:1
+11 WRITE "DEVICE UNAVAILABLE"
GOTO DEVSEL
End DoDot:1
+12 QUIT
FIND ; FIND REJECTIONS BY RELEASE DATE "B" CROSS REFERENCE
+1 NEW ABSPDONE,ABSPRDT,ABSPCARD,ABSPGRP,ABSPCLMI,ABSPRCNT,ABSPRNUM
+2 ;IHS/OIT/SCR 082109 patch 34
NEW ABSPCODE,ABSPQUIT
+3 SET ABSPRDT=ABSPSTRT-1
+4 SET ABSPDONE=0
+5 SET ABSPRMI=""
+6 FOR
SET ABSPRDT=$ORDER(^ABSPECX("RPT","B",ABSPRDT))
IF ABSPRDT=""!ABSPDONE
QUIT
Begin DoDot:1
+7 IF ABSPRDT>ABSPEND
SET ABSPDONE=1
QUIT
+8 SET ABSPTMP(ABSPRDT)=""
+9 FOR ABSPJ=1:1
SET ABSPRMI=$ORDER(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI))
IF ABSPRMI'=+ABSPRMI
QUIT
Begin DoDot:2
+10 SET ABSPQUIT=0
+11 ; NOT A REJECTED CLAIM
IF $PIECE(^ABSPECX("RPT",ABSPRMI,0),U,6)'=1
QUIT
+12 SET ABSPTRNS=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,3)
SET ABSPTINS=$PIECE(^ABSPTL(ABSPTRNS,1),U,6)
+13 SET ABSPPHM1=""
+14 ; NOT SELECTED INSURER
IF ABSPINS'="ALL"
IF ABSPTINS'=ABSPINS
QUIT
+15 IF ABSPPPHM'="ALL"
Begin DoDot:3
+16 ; NOT SELECTED PHARMACY
IF $PIECE(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPPHM
QUIT
+17 SET ABSPPHM1=ABSPPPHM
+18 QUIT
End DoDot:3
+19 ; SET PHARMACY
IF ABSPPPHM="ALL"
SET ABSPPHM1=$PIECE(^ABSPTL(ABSPTRNS,1),U,7)
+20 IF ABSPPHM1=""
QUIT
+21 ;IHS/OIT/SCR 082109 START changes patch 34
+22 ;QUIT IF NOT SELECTED REJECT CODE
IF ABSPREJ'="ALL"
Begin DoDot:3
+23 IF $DATA(^ABSPECX("RPT",ABSPRMI,"R",0))
Begin DoDot:4
+24 SET ABSPREA=$PIECE($GET(^ABSPECX("RPT",ABSPRMI,"R",1,0)),U,1)
+25 SET ABSPNUM=$PIECE(ABSPREA,":",1)
End DoDot:4
+26 IF ABSPREJX'=ABSPNUM
SET ABSPQUIT=1
+27 QUIT
End DoDot:3
+28 IF ABSPQUIT
QUIT
+29 ;IHS/OIT/SCR 082109 END changes patch 34
+30 IF $DATA(^ABSPECX("RPT",ABSPRMI,"R",0))
Begin DoDot:3
+31 SET ABSPREA=$PIECE(^ABSPECX("RPT",ABSPRMI,"R",1,0),U,1)
+32 SET ABSPRNUM=$PIECE(ABSPREA,":",1)
+33 SET ABSPRCD="R"
+34 QUIT
End DoDot:3
+35 IF '$DATA(^ABSPECX("RPT",ABSPRMI,"R",0))
Begin DoDot:3
+36 SET ABSPREA=$PIECE($GET(^ABSPECX("RPT",ABSPRMI,"M",1,0)),U,1)
+37 IF ABSPREA=""
SET ABSPREA="UKN"
+38 SET ABSPRNUM="999"
+39 ; GET reason
SET ABSPRCD="M"
+40 QUIT
End DoDot:3
+41 SET ABSPCLMI=$PIECE(^ABSPTL(ABSPTRNS,0),"^",4)
+42 SET ABSPGRP=""
+43 SET ABSPCARD=""
+44 IF ABSPCLMI'=""
Begin DoDot:3
+45 ;TRANSACTION:CLAIM:Cardholder ID Number
SET ABSPCARD=$PIECE($GET(^ABSPC(ABSPCLMI,300)),"^",2)
+46 ;STRIP THE 2 CHARACTER QUALIFIER
SET ABSPCARD=$EXTRACT(ABSPCARD,3,$LENGTH(ABSPCARD))
+47 ;TRANSACTION:CLAIM:Group Number
SET ABSPGRP=$PIECE($GET(^ABSPC(ABSPCLMI,300)),"^",1)
+48 ;STRIP THE 2 CHARACTER QUALIFIER
SET ABSPGRP=$EXTRACT(ABSPGRP,3,$LENGTH(ABSPGRP))
End DoDot:3
+49 ;S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM)),"^",1)+1
+50 ;IHS/OIT/SCR 110309 patch 35
SET ABSPRCNT=$PIECE($GET(ABSPREAS(ABSPRNUM,ABSPPHM1)),"^",1)+1
+51 ;S ABSPREAS(ABSPRNUM)=ABSPRCNT_"^"_ABSPREA ;COUNT OF REJECT REASON TYPE^REJECT REASON
+52 ;IHS/OIT/SCR 110309 patch 35
SET ABSPREAS(ABSPRNUM,ABSPPHM1)=ABSPRCNT_"^"_ABSPREA
+53 SET ABSPTMP(ABSPRDT,ABSPPHM1,ABSPTINS,ABSPRNUM,ABSPRMI)=ABSPREA_"^"_$PIECE(^ABSPTL(ABSPTRNS,5),U,5)_"^"_$PIECE(^ABSPTL(ABSPTRNS,0),U,6)_"^"_$PIECE(^ABSPTL(ABSPTRNS,1),U,6)_"^"_ABSPCARD_"^"_ABSPGRP
End DoDot:2
End DoDot:1
+54 QUIT
NEXT ; WHAT TO DO NEXT
+1 NEW ABSPSTOP,ABSPOUT
+2 SET (ABSPSTOP,ABSPOUT)=0
+3 IF $ORDER(ABSPTMP(""))=""
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
+2 USE IO
IF $DATA(ABSPSUM)
WRITE @IOF
+3 SET Y=ABSPSTRT
+4 DO DD^%DT
+5 SET ABSPFBDT=Y
+6 SET Y=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
+1 ; TOTAL COUNTS BY REJECT CODE (1ST ON LIST)
+2 ; AND TOTAL AMT PER EACH THAT WAS REJECTED
+3 NEW ABSPPCNT
+4 SET ABSPSRDT=""
+5 FOR
SET ABSPSRDT=$ORDER(ABSPTMP(ABSPSRDT))
IF ABSPSRDT=""
QUIT
Begin DoDot:1
+6 SET ABSPSPHM=""
+7 FOR
SET ABSPSPHM=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM))
IF ABSPSPHM=""
QUIT
Begin DoDot:2
+8 SET ABSPSTIN=""
+9 FOR
SET ABSPSTIN=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN))
IF ABSPSTIN=""
QUIT
Begin DoDot:3
+10 SET ABSPSRNM=""
+11 FOR
SET ABSPSRNM=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM))
IF ABSPSRNM=""
QUIT
Begin DoDot:4
+12 SET ABSPSTTL=0
SET ABSPSRMI=""
SET ABSPSTL1=0
+13 FOR
SET ABSPSRMI=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI))
IF ABSPSRMI=""
QUIT
Begin DoDot:5
+14 SET ABSPSREA=$PIECE(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,1)
+15 ;S ABSPPCNT=$P(ABSPREAS(""_ABSPSRNM_""),U,1) ; GET COUNT OF THIS REJECTION REASON
+16 ;IHS/OIT/SCR 110309 patch 35
SET ABSPPCNT=$PIECE(ABSPREAS(""_ABSPSRNM_"",ABSPSPHM),U,1)
+17 SET ABSPSTTL=ABSPSTTL+$PIECE(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,2)
End DoDot:5
+18 SET ABSPSTL1=ABSPSTTL+$PIECE($GET(ABSPSUM(ABSPSPHM,ABSPSRNM)),U,2)
+19 SET ABSPSUM(ABSPSPHM,ABSPSRNM)=ABSPSREA_"^"_ABSPSTL1_"^"_ABSPSTIN_"^"_ABSPPCNT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
PRNTSUM ; PRINT THE SUMMARY REPORT
+1 NEW ABSPGCNT,ABSPPCNT,ABSPSTOP
+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 SET ABSPPHMN=$PIECE(^ABSP(9002313.56,ABSPPPHM,0),U,1)
+16 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
+17 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""PHARMACY: "",ABSPPHMN")
+18 IF ABSPOUT
QUIT
+19 SET ABSPPRNM=""
+20 SET ABSPRTOT=0
+21 ;IHS/OIT/SCR 110309 this is pharmacy count
SET ABSPPCNT=0
+22 ;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen, use paging.
+23 SET ABSPOUT=$$WRITE^ABSPOSUU("!?2,""REJECTION CODE: "",?58,"" TOTALED: "",?68,"" RX COUNT: """)
+24 IF ABSPOUT
QUIT
+25 FOR
SET ABSPPRNM=$ORDER(ABSPSUM(ABSPPPHM,ABSPPRNM))
IF (ABSPPRNM="")!(ABSPSTOP)
QUIT
Begin DoDot:2
+26 IF ABSPOUT
SET ABSPSTOP=1
QUIT
+27 SET ABSPDRTR=$PIECE(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1)
+28 IF ABSPDRTR'=""
Begin DoDot:3
+29 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
+30 SET ABSPOUT=$$WRITE^ABSPOSUU("!?0,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1),?60,$J($P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2),7,2),?72,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)")
+31 IF ABSPOUT
QUIT
+32 SET ABSPRTOT=ABSPRTOT+$PIECE(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2)
+33 SET ABSPPCNT=ABSPPCNT+$PIECE(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)
End DoDot:3
+34 IF ABSPOUT
QUIT
End DoDot:2
+35 IF ABSPSTOP
QUIT
+36 IF ABSPOUT
QUIT
+37 SET ABSPGTOT=ABSPGTOT+ABSPRTOT
+38 SET ABSPGCNT=ABSPGCNT+ABSPPCNT
+39 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+40 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR PHARMACY: $"",ABSPRTOT")
+41 IF ABSPOUT
QUIT
+42 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED FOR PHARMACY: "",ABSPPCNT")
+43 IF ABSPOUT
QUIT
End DoDot:1
+44 IF ABSPSTOP
QUIT
+45 IF ABSPOUT
QUIT
+46 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+47 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: $"",ABSPGTOT")
+48 IF ABSPOUT
QUIT
+49 IF $Y<3
WRITE !
SET ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED: "",ABSPGCNT")
+50 ;W:$Y<3 ! W !!,"P - Preventable, N - Non-recoverable, B - Both"
+51 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 #"",?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
+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(ABSPTMP(ABSPPRDT))
IF (ABSPPRDT="")!(ABSPQUIT)!(ABSPOUT)
QUIT
Begin DoDot:1
+15 SET ABSPPPHM=""
+16 SET Y=ABSPPRDT
+17 DO DD^%DT
+18 ; FORMATTED RELEASE DATE
SET ABSPFRDT=Y
+19 SET ABSPRDTL=0
+20 FOR
SET ABSPPPHM=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM))
IF (ABSPPPHM="")!(ABSPOUT)
QUIT
Begin DoDot:2
+21 SET ABSPPINS=""
+22 SET ABSPPHMN=$PIECE(^ABSP(9002313.56,ABSPPPHM,0),U,1)
+23 DO PRNTDHD
+24 IF ABSPOUT
QUIT
+25 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+26 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""PHARMACY: "",ABSPPHMN,"" RELEASED DATE: "",ABSPFRDT")
+27 IF ABSPOUT
QUIT
+28 SET ABSPBTOT=0
+29 FOR
SET ABSPPINS=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS))
IF (ABSPPINS="")!(ABSPOUT)
QUIT
Begin DoDot:3
+30 SET ABSPPRNM=""
+31 FOR
SET ABSPPRNM=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM))
IF (ABSPPRNM="")!(ABSPOUT)
QUIT
Begin DoDot:4
+32 SET ABSPPRMI=""
+33 ;IHS/OIT/SCR 111309 patch 35
SET ABSPRJCD=$PIECE(ABSPREAS(""_ABSPPRNM_"",ABSPPPHM),U,2)
+34 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+35 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?15,""REJECTION CODE: "",$E(ABSPRJCD,1,48)")
+36 IF ABSPOUT
QUIT
+37 FOR
SET ABSPPRMI=$ORDER(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI))
IF (ABSPPRMI="")!(ABSPOUT)
QUIT
Begin DoDot:5
+38 SET (ABSPPCHT,ABSPPDIV,ABSPOPS)=""
+39 SET ABSPPAT=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,3)
+40 SET ABSPCARD=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,5)
+41 SET ABSPGRP=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,6)
+42 SET ABSPPATN=$EXTRACT($PIECE(^DPT(ABSPPAT,0),U,1),1,20)
+43 ;OUTPATIENT SITE MIGHT NOT BE DEFINED
SET ABSPOPS=$PIECE($GET(^ABSP(9002313.56,ABSPPPHM,"OPSITE",1,0)),U,1)
+44 ;NO OUTPATIENT SITE MEANS NO DIVISION
IF ABSPOPS'=""
SET ABSPPDIV=$PIECE($GET(^PS(59,ABSPOPS,0)),U,6)
+45 ;NO DIVISION MEANS NO CHART #
IF ABSPPDIV'=""
SET ABSPPCHT=$PIECE($GET(^AUPNPAT(ABSPPAT,41,ABSPPDIV,0)),U,2)
+46 SET ABSPPRX=$PIECE(^ABSPECX("RPT",ABSPPRMI,0),U,4)
+47 ; SET INTERNAL RX # AND REFILL #
SET ABSPPRXR=$PIECE($GET(^ABSPECX("RPT",ABSPPRMI,0)),U,5)
+48 ; PRICE
SET ABSPPTP=$PIECE(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,2)
+49 ; INSURER NAME
SET ABSPINSN=$EXTRACT($PIECE($GET(^AUTNINS(ABSPPINS,0)),U,1),1,22)
+50 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name BEGIN
+51 NEW ABSPTRNS,ABSPCLMI
+52 SET ABSPTRNS=$PIECE($GET(^ABSPECX("RPT",ABSPPRMI,0)),"^",3)
+53 SET ABSPCLMI=$PIECE($GET(^ABSPTL(ABSPTRNS,0)),"^",4)
+54 SET NDCDRG=$$GTNDCDRG^ABSPOSUU(ABSPCLMI,ABSPPRX)
+55 SET ABSPNDC=$PIECE(NDCDRG,"^",1)
+56 SET ABSPDRNM=$PIECE(NDCDRG,"^",2)
+57 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+58 SET ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPPCHT,?9,ABSPPATN,?31,ABSPPRX_""/""_ABSPPRXR,?45,ABSPINSN,?70,""$""_$J(ABSPPTP,6,2)")
+59 IF ABSPOUT
QUIT
+60 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name
+61 SET ABSPOUT=$$WRITE^ABSPOSUU("!,?3,ABSPCARD,?27,ABSPGRP,?40,ABSPNDC,?60,ABSPDRNM")
+62 IF ABSPOUT
QUIT
+63 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.
+64 SET ABSBPRTT=ABSPRTOT+ABSPPTP
+65 SET ABSPBTOT=ABSPPTP+ABSPBTOT
+66 SET ABSPRDTL=ABSPRDTL+ABSPPTP
End DoDot:5
End DoDot:4
+67 IF ABSPOUT
QUIT
End DoDot:3
+68 IF ABSPOUT
QUIT
+69 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+70 SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR "",ABSPPHMN,"": $"",$J(ABSPBTOT,6,2),!")
End DoDot:2
+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 RELEASED DATE "",ABSPFRDT,"": $"",$J(ABSPRDTL,6,2)")
+74 IF ABSPOUT
QUIT
+75 SET ABSPGTOT=ABSPGTOT+ABSPRDTL
End DoDot:1
+76 IF ABSPSTOP
QUIT
+77 IF ABSPOUT
QUIT
+78 ;I $D(ABSPRTYP) W !!,"TOTAL AMOUNT REJECTED: ",ABSBPRTT,!!,"P - Preventable, N - Non-recoverable, B - Both"
+79 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging
+80 IF $DATA(ABSPRTYP)
SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL AMOUNT REJECTED: $"",$J(ABSPGTOT,6,2),!!")
+81 QUIT
ZEND ; END AND KILL VARIABLES
+1 DO ^%ZISC
+2 KILL 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
End DoDot:1
+10 QUIT
BDT() ; ENTER BEGINING DATE
+1 NEW ABSPBDT,DIR,X1,X
+2 WRITE !
+3 KILL DIR
+4 SET DIR(0)="DEX"
+5 SET DIR("A")="Enter Beginning Prescription Release Date"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
QUIT -1
+8 SET ABSPBDT=+Y
+9 SET X1=ABSPBDT
DO C^%DTC
+10 QUIT X
EDT() ; ENTER END DATE
+1 NEW ABSPEDT,DIR,X1,X
+2 WRITE !
+3 KILL DIR
+4 SET DIR(0)="DEX"
+5 SET DIR("A")="Enter Ending Prescription Release Date"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
QUIT -1
+8 SET ABSPEDT=+Y
+9 SET X1=ABSPEDT
DO C^%DTC
+10 QUIT X
