ABSPOSR9 ;IHS/OIT/SCR - COLLECTION PRODUCTIVITY REPORT
;;1.0;PHARMACY POINT OF SALE;**38,40**;JUN 21, 2001;Build 38
; OPTION: ABSP RPT COLLECTION PRODUCT
; DISPLAYS COST AMOUNT RECOVERED FOR TRANSACTIONS THAT WERE REJECTED AT ONE TIME AND HAVE
; BECOME PAYABLE FOR A RANGE OF RELEASE DATES LIKE THE WRR, BUT ALSO INCLUDES
; REJECT CODES FROM THE MOST RECENT REJECTED TRANSACTION AND IDENTIFIES FIELDS AND MODIFIED
; VALUES THAT WERE USED TO MAKE THE CLAIM PAYABLE
EN ; EP
N ABSPQUIT,ABSPDONE,ABSPQUIT,ABSPPHRM,ABSPTMP,ABSPREJS,Y,X1,X2,ABSPEND,ABSPSTRT,ABSPDAT,ABSPPRXI
N ABSPPHMP,ABSPPHMI,ABSPDATP,ABSPDATI,ABSPGRNP,ABSPGRNI,ABSPUSR,ABSPCNT,STARTIME,STOPTIME
;D AUTO^ABSPOSM1()
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
.Q:ABSPQUIT
.S ABSPEND=$$EDT()
.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 ABSPPHRM=$$CLNC()
Q:ABSPPHRM=-1
S ABSPUSR=$$USER()
D ^XBCLS
S ABSPTMP=""
;D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,.ABSPTMP) IHS/OIT/SCR 083109 patch 34
S STARTIME=$H
D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,.ABSPTMP,.ABSPREJS)
S STOPTIME=$H
S ^TMP("ABSPOSR9-RUNLOG",$J,STARTIME)=ABSPSTRT_"^"_ABSPEND_"^"_($P(STOPTIME,",",2)-$P(STARTIME,",",2)) ;IHS/OIT/CNI/RAN patch 40 081810 added for bench-mark
S Y=ABSPSTRT D DD^%DT S ABSPFROM=Y
S Y=ABSPEND D DD^%DT S ABSPTO=Y
I $O(ABSPTMP(""))="" D
.W !," ****NO RECORDS FOUND FOR DATE RANGE***",!!
.N DIR
.S DIR(0)="Y"
.S DIR("A")="PRINT ANYWAY"
.D ^DIR
.I Y'=1 S ABSPQUIT=1
.Q
Q:ABSPQUIT
D DEVSEL
D PRHDR(ABSPSTRT,ABSPEND)
S ABSPSDAT=""
S ABSPGRNP=0,ABSPGRNI=0 ;IHS/OIT/SCR 082709 patch 34
F S ABSPSDAT=$O(ABSPTMP(ABSPSDAT)) Q:(ABSPSDAT="")!(ABSPQUIT) D
.S ABSPDATP=0,ABSPDATI=0 ;IHS/OIT/SCR 082709 patch 34
.S ABSPPHRM=""
.S Y=ABSPSDAT
.D DD^%DT
.;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
.S ABSPQUIT=$$WRITE^ABSPOSUU("!!?10,""RELEASED DATE: ""_Y")
.Q:ABSPQUIT
.F S ABSPPHRM=$O(ABSPTMP(ABSPSDAT,ABSPPHRM)) Q:(ABSPPHRM="")!(ABSPQUIT) D
..S ABSPPHMP=0,ABSPPHMI=0
..;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen, use paging
..S ABSPQUIT=$$WRITE^ABSPOSUU("!?15,""PHARMACY: ""_$P($G(^ABSP(9002313.56,ABSPPHRM,0)),U,1)")
..Q:ABSPQUIT
..I ABSPUSR="ALL" S ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ALL""")
..Q:ABSPQUIT
..I ABSPUSR'="ALL" S ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ""_$P($G(^VA(200,ABSPUSR,0)),U,1)")
..Q:ABSPQUIT
..S ABSPPRXI=""
..F S ABSPPRXI=$O(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI)) Q:(ABSPPRXI="")!(ABSPQUIT) D
...;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
...S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""RX #/REFILL: `""_ABSPPRXI_""/""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,1)")
...Q:ABSPQUIT
...S Y=$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",2) D DD^%DT
...;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
...S ABSPQUIT=$$WRITE^ABSPOSUU("!?5,""TRANSACTION DATE: ""_Y,?40,""RECOVERED BY: ""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,5)")
...Q:ABSPQUIT
...;W !?0,"TOTAL PRICE: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",3),?25,"PAID BY INSURER: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",4) ;IHS/OIT/SCR 122909 patch 36
...;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
...S ABSPQUIT=$$WRITE^ABSPOSUU("!?5,""TOTAL PRICE: ""_$FNUMBER($P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,3),"","",2),?40,""PAID BY INSURER: ""_$FNUMBER($P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,4),"","",2)")
...Q:ABSPQUIT
...S ABSPPHMP=ABSPPHMP+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",3)
...S ABSPPHMI=ABSPPHMI+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",4)
...;PRINT OUT REJECTION REASONS FOR THE REJECTION BEFORE THE PAID TXN
...S ABSPCNT=0
...F S ABSPCNT=$O(ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT)) Q:(ABSPCNT="")!(ABSPQUIT) D
....;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
....S ABSPQUIT=$$WRITE^ABSPOSUU("!?15,ABSPCNT_"". REJECTION CODE: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""CODE"")")
....Q:ABSPQUIT
....S ABSPQUIT=$$WRITE^ABSPOSUU("?20,""REASON: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""REASON"")")
....Q:ABSPQUIT
...Q:ABSPQUIT
...;PRINT OUT FIELDS AND VALUES OF ENTRIES IN ABSP NCPDP OVERRIDE FILE FOR THIS TXN
...;W !!
...;S ABSPCNT=0
...;F S ABSPCNT=$O(ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT)) Q:ABSPCNT="" D
...;.W !,?5,"MOST RECENT OVERIDE FIELD: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"FIELD")
...;.W !,?15,"CHANGED TO: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"NEW VALUE")
..Q:ABSPQUIT
..;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
..S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""PHARMACY TOTAL ""_$FNUMBER(ABSPPHMP,"","",2),?40,""INSURER PAID: ""_$FNUMBER(ABSPPHMI,"","",2)")
..Q:ABSPQUIT
..S ABSPDATP=ABSPDATP+ABSPPHMP
..S ABSPDATI=ABSPDATI+ABSPPHMI
.;W !!,"TOTAL PRICE FOR DATE: "_ABSPPHMP,?25,"TOTAL PAID BY INSURER FOR DATE: "_ABSPPHMI
.Q:ABSPQUIT
.;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
.S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""DATE TOTAL: ""_$FNUMBER(ABSPPHMP,"","",2),?40,""TOTAL PAID BY INSURER FOR DATE: ""_$FNUMBER(ABSPPHMI,"","",2)")
.Q:ABSPQUIT
.S ABSPGRNP=ABSPGRNP+ABSPDATP
.S ABSPGRNI=ABSPGRNI+ABSPDATI
I ABSPQUIT D ZEND Q
;W !!,"GRAND TOTAL PRICE: "_ABSPGRNP,?25,"GRAND TOTAL PAID BY INSURER :"_ABSPGRNI
;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: ""_$FNUMBER(ABSPGRNP,"","",2),?40,""GRAND TOTAL INSURER PAID: ""_$FNUMBER(ABSPGRNI,"","",2)")
D ZEND ;IHS/OIT/SCR 1/4/09 patch 36 close the printer device
Q
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
N DIC,X,Y,ABSPPHRM
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 ABSPPHRM="ALL"
I Y>-1 S ABSPPHRM=$P(Y,"^",1)
Q ABSPPHRM
USER() ; PICK WHICH OR ALL NEW PESRSON
;IHS/OIT/SCR 083109 patch 34
N DIC,X,Y,ABSPUSER
S DIC="^VA(200,"
S DIC(0)="AEMQVZ"
S DIC("A")="Please Select a User or leave blank for ALL: "
D ^DIC K DIC
I X["^" Q -1
I Y=-1 S ABSPUSER="ALL"
I Y>-1 S ABSPUSER=$P(Y,"^",1)
Q ABSPUSER
DEVSEL ; SELECT DEVICE
N ABSPSTOP
S ABSPSTOP=0
D ^%ZIS
I POP D
.D ^%ZIS
.Q
I $D(DUOUT) D
.D ZEND
.S ABSPSTOP=1
.Q
Q:ABSPSTOP
I POP D
.W "DEVICE UNAVAILABLE" G DEVSEL
Q
FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,ABSPTMP,ABSPREJS) ; FIND PAYABLE CLAIMS IN A DATE RANGE, AND THEN DETERMINE IF THEY WERE REJECTED AT ONE TIME...
N ABSPDONE,ABSPRDT,ABSPTDAT,ABSPTRXN,ABSPPHM1,APSPTRXI,ABSPRICE,ABSPFND,ABSPRXI,ABSPTRXR,ABSPRXN,ABSPTRXR
N ABSPUSR1,ABSPUSRN,ABSPRESP,ABSPPSTN,ABSPCNT
;S ABSPUSR1=0
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
.F ABSPJ=1:1 S ABSPRMI=$O(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI)) Q:ABSPRMI'=+ABSPRMI D
..I $P(^ABSPECX("RPT",ABSPRMI,0),U,6)'=4 Q ; NOT A PAYABLE CLAIM
..S ABSPTRNS=$P(^ABSPECX("RPT",ABSPRMI,0),U,3)
..S ABSPPHM1=""
..I ABSPPHRM'="ALL" D
...I $P(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPHRM Q ; NOT SELECTED PHARMACY
...S ABSPPHM1=ABSPPHRM
...Q
..I ABSPPHRM="ALL" S ABSPPHM1=$P(^ABSPTL(ABSPTRNS,1),U,7) ; SET PHARMACY
..I ABSPPHM1="" Q
..S ABSPUSR1=-1
..I ABSPUSR'="ALL" D
...I $P(^ABSPTL(ABSPTRNS,0),U,17)'=ABSPUSR Q ; NOT SELECTED USER
...S ABSPUSR1=ABSPUSR
...Q
..I ABSPUSR="ALL" S ABSPUSR1=$P(^ABSPTL(ABSPTRNS,1),U,17) ; SET USER
..I ABSPUSR1=-1 Q
..;IHS/OIT/SCR 083109 patch 32 END
..S ABSPTRXI=$P(^ABSPTL(ABSPTRNS,1),U,11)
..S ABSPTRXR=$P(^ABSPTL(ABSPTRNS,1),U,1)
..I ABSPTRXI=""!(ABSPTRXR="") Q
..;NOW WE HAVE A PAYABLE CLAIM...BUT IT ONLY BELONGS ON THIS REPORT IF IT HAS BEEN REJECTED BEFORE
..;SO....WE HAVE TO LOOK AT THE LOG OF TRANSACTIONS FOR THIS PRESCRIPTION BEFORE THE ONE
..;WE HAVE IN OUR HANDS...IF THAT ONE WAS REJECTED, PUT THIS INFO ON THE REPORT
..;Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,""),-1) ;FOUND IN ABSPOS57 AND ABSPOSBB
..S ABSPFND=0
..S ABSPTRN1=""
..F S ABSPTRN1=$O(^ABSPTL("NON-FILEMAN","RXIRXR",ABSPTRXI,ABSPTRXR,ABSPTRN1),-1) Q:ABSPTRN1=""!(ABSPFND=1) D
...S ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRN1_",","RESULT WITH REVERSAL")
...S ABSPRESP=$P(^ABSPTL(ABSPTRNS,0),U,5) ;POINTER TO RESPONSE FILE
...S ABSPPSTN=$P(^ABSPTL(ABSPTRNS,0),U,9) ;POSITION IN CLAIM
...;I ABSPRWR="E REJECTED" D
...I (ABSPRWR="E REJECTED")!(ABSPRWR="PAPER") D
....S ABSPPAID=0
....I (ABSPRESP'="")&(ABSPPSTN'="") S ABSPPAID=$$509^ABSPOS03(ABSPRESP,ABSPPSTN) ;(#509) Total Amount Paid
....S ABSPFND=1
....S ABSPRXI=$P(^ABSPECX("RPT",ABSPRMI,0),U,4) ;POINTER TO PRESCRIPTION FILE
....S ABSPRXN=$P($G(^PSRX(ABSPRXI,0)),U,1) ;PRESCRIPTION NUMBER
....S ABSPTDAT=$P(^ABSPECX("RPT",ABSPRMI,0),U,2) ;TRANSACTION LAST UPDATE
....S ABSPTRXR=$P(^ABSPECX("RPT",ABSPRMI,0),U,5) ;REFIL NUMBER
....S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5) ;TOTAL PRICE
....S ABSPUSRI=$P(^ABSPTL(ABSPTRNS,0),U,17) ;USER LAST UPDATED - IHS/OIT/SCR 082709 patch 34
....;S ABSPUSRI=$P(^ABSPTL(ABSPTRNS,0),U,10)
....S ABSPUSRN=""
....;S ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
....S:ABSPUSRI>0 ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
....S ABSPTMP(ABSPRDT,ABSPPHM1,ABSPRXI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPUSRN
....;This populates ABSPREJS(n) with code:text format of each rejection for this position in this response
....S ABSPCNT=0
....S ABSPRSP=$P(^ABSPTL(ABSPTRN1,0),U,5) ;POINTER TO RESPONSE FILE for REJECTED transaction
....S ABSPSTN=$P(^ABSPTL(ABSPTRN1,0),U,9) ;POSITION IN CLAIM for REJECTED transaction
....I $G(ABSPRSP)'="" D
.....;FOR EACH REJECTION CODE AND REASON associated to the REJECTED TRANSACTION, add it to an array
.....D REJTEXT^ABSPOS03(ABSPRSP,ABSPSTN,.ABSPREJS)
.....F S ABSPCNT=$O(ABSPREJS(ABSPCNT)) Q:(ABSPCNT=""!ABSPQUIT) D
......S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPRXI,ABSPCNT,"CODE")=$P(ABSPREJS(ABSPCNT),":",1)
......S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPRXI,ABSPCNT,"REASON")=$P(ABSPREJS(ABSPCNT),":",2)
Q
PRHDR(ABSPSTRT,ABSPEND) ; PRINT HEADER
N ABSPFEDT,ABSPFBDT
U IO W @IOF
S Y=ABSPSTRT
D DD^%DT
S ABSPFBDT=Y
S Y=ABSPEND
D DD^%DT
S ABSPFEDT=Y
W !,?19,"Pharmacy Point of Sale Collection Productivity Report"
W !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT
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
ZEND ;Close the device that was opened
D ^%ZISC
Q
ABSPOSR9 ;IHS/OIT/SCR - COLLECTION PRODUCTIVITY REPORT
+1 ;;1.0;PHARMACY POINT OF SALE;**38,40**;JUN 21, 2001;Build 38
+2 ; OPTION: ABSP RPT COLLECTION PRODUCT
+3 ; DISPLAYS COST AMOUNT RECOVERED FOR TRANSACTIONS THAT WERE REJECTED AT ONE TIME AND HAVE
+4 ; BECOME PAYABLE FOR A RANGE OF RELEASE DATES LIKE THE WRR, BUT ALSO INCLUDES
+5 ; REJECT CODES FROM THE MOST RECENT REJECTED TRANSACTION AND IDENTIFIES FIELDS AND MODIFIED
+6 ; VALUES THAT WERE USED TO MAKE THE CLAIM PAYABLE
EN ; EP
+1 NEW ABSPQUIT,ABSPDONE,ABSPQUIT,ABSPPHRM,ABSPTMP,ABSPREJS,Y,X1,X2,ABSPEND,ABSPSTRT,ABSPDAT,ABSPPRXI
+2 NEW ABSPPHMP,ABSPPHMI,ABSPDATP,ABSPDATI,ABSPGRNP,ABSPGRNI,ABSPUSR,ABSPCNT,STARTIME,STOPTIME
+3 ;D AUTO^ABSPOSM1()
+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
+11 QUIT
End DoDot:2
+12 IF ABSPQUIT
QUIT
+13 SET ABSPEND=$$EDT()
+14 IF ABSPEND=-1
Begin DoDot:2
+15 SET ABSPQUIT=1
+16 SET ABSPDONE=1
+17 QUIT
End DoDot:2
+18 IF ABSPQUIT
QUIT
+19 IF ABSPSTRT<0
SET ABSPDONE=1
QUIT
+20 IF ABSPEND<0
SET ABSPDONE=1
QUIT
+21 SET X2=ABSPSTRT
SET X1=ABSPEND
DO ^%DTC
+22 IF X<0
DO EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")
+23 IF X>=0
SET ABSPDONE=1
+24 QUIT
End DoDot:1
+25 IF ABSPQUIT
QUIT
+26 SET ABSPPHRM=$$CLNC()
+27 IF ABSPPHRM=-1
QUIT
+28 SET ABSPUSR=$$USER()
+29 DO ^XBCLS
+30 SET ABSPTMP=""
+31 ;D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,.ABSPTMP) IHS/OIT/SCR 083109 patch 34
+32 SET STARTIME=$HOROLOG
+33 DO FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,.ABSPTMP,.ABSPREJS)
+34 SET STOPTIME=$HOROLOG
+35 ;IHS/OIT/CNI/RAN patch 40 081810 added for bench-mark
SET ^TMP("ABSPOSR9-RUNLOG",$JOB,STARTIME)=ABSPSTRT_"^"_ABSPEND_"^"_($PIECE(STOPTIME,",",2)-$PIECE(STARTIME,",",2))
+36 SET Y=ABSPSTRT
DO DD^%DT
SET ABSPFROM=Y
+37 SET Y=ABSPEND
DO DD^%DT
SET ABSPTO=Y
+38 IF $ORDER(ABSPTMP(""))=""
Begin DoDot:1
+39 WRITE !," ****NO RECORDS FOUND FOR DATE RANGE***",!!
+40 NEW DIR
+41 SET DIR(0)="Y"
+42 SET DIR("A")="PRINT ANYWAY"
+43 DO ^DIR
+44 IF Y'=1
SET ABSPQUIT=1
+45 QUIT
End DoDot:1
+46 IF ABSPQUIT
QUIT
+47 DO DEVSEL
+48 DO PRHDR(ABSPSTRT,ABSPEND)
+49 SET ABSPSDAT=""
+50 ;IHS/OIT/SCR 082709 patch 34
SET ABSPGRNP=0
SET ABSPGRNI=0
+51 FOR
SET ABSPSDAT=$ORDER(ABSPTMP(ABSPSDAT))
IF (ABSPSDAT="")!(ABSPQUIT)
QUIT
Begin DoDot:1
+52 ;IHS/OIT/SCR 082709 patch 34
SET ABSPDATP=0
SET ABSPDATI=0
+53 SET ABSPPHRM=""
+54 SET Y=ABSPSDAT
+55 DO DD^%DT
+56 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+57 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!?10,""RELEASED DATE: ""_Y")
+58 IF ABSPQUIT
QUIT
+59 FOR
SET ABSPPHRM=$ORDER(ABSPTMP(ABSPSDAT,ABSPPHRM))
IF (ABSPPHRM="")!(ABSPQUIT)
QUIT
Begin DoDot:2
+60 SET ABSPPHMP=0
SET ABSPPHMI=0
+61 ;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen, use paging
+62 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?15,""PHARMACY: ""_$P($G(^ABSP(9002313.56,ABSPPHRM,0)),U,1)")
+63 IF ABSPQUIT
QUIT
+64 IF ABSPUSR="ALL"
SET ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ALL""")
+65 IF ABSPQUIT
QUIT
+66 IF ABSPUSR'="ALL"
SET ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ""_$P($G(^VA(200,ABSPUSR,0)),U,1)")
+67 IF ABSPQUIT
QUIT
+68 SET ABSPPRXI=""
+69 FOR
SET ABSPPRXI=$ORDER(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI))
IF (ABSPPRXI="")!(ABSPQUIT)
QUIT
Begin DoDot:3
+70 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+71 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""RX #/REFILL: `""_ABSPPRXI_""/""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,1)")
+72 IF ABSPQUIT
QUIT
+73 SET Y=$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",2)
DO DD^%DT
+74 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+75 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?5,""TRANSACTION DATE: ""_Y,?40,""RECOVERED BY: ""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,5)")
+76 IF ABSPQUIT
QUIT
+77 ;W !?0,"TOTAL PRICE: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",3),?25,"PAID BY INSURER: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",4) ;IHS/OIT/SCR 122909 patch 36
+78 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+79 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?5,""TOTAL PRICE: ""_$FNUMBER($P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,3),"","",2),?40,""PAID BY INSURER: ""_$FNUMBER($P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,4),"","",2)")
+80 IF ABSPQUIT
QUIT
+81 SET ABSPPHMP=ABSPPHMP+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",3)
+82 SET ABSPPHMI=ABSPPHMI+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",4)
+83 ;PRINT OUT REJECTION REASONS FOR THE REJECTION BEFORE THE PAID TXN
+84 SET ABSPCNT=0
+85 FOR
SET ABSPCNT=$ORDER(ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT))
IF (ABSPCNT="")!(ABSPQUIT)
QUIT
Begin DoDot:4
+86 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+87 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?15,ABSPCNT_"". REJECTION CODE: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""CODE"")")
+88 IF ABSPQUIT
QUIT
+89 SET ABSPQUIT=$$WRITE^ABSPOSUU("?20,""REASON: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""REASON"")")
+90 IF ABSPQUIT
QUIT
End DoDot:4
+91 IF ABSPQUIT
QUIT
+92 ;PRINT OUT FIELDS AND VALUES OF ENTRIES IN ABSP NCPDP OVERRIDE FILE FOR THIS TXN
+93 ;W !!
+94 ;S ABSPCNT=0
+95 ;F S ABSPCNT=$O(ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT)) Q:ABSPCNT="" D
+96 ;.W !,?5,"MOST RECENT OVERIDE FIELD: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"FIELD")
+97 ;.W !,?15,"CHANGED TO: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"NEW VALUE")
End DoDot:3
+98 IF ABSPQUIT
QUIT
+99 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+100 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""PHARMACY TOTAL ""_$FNUMBER(ABSPPHMP,"","",2),?40,""INSURER PAID: ""_$FNUMBER(ABSPPHMI,"","",2)")
+101 IF ABSPQUIT
QUIT
+102 SET ABSPDATP=ABSPDATP+ABSPPHMP
+103 SET ABSPDATI=ABSPDATI+ABSPPHMI
End DoDot:2
+104 ;W !!,"TOTAL PRICE FOR DATE: "_ABSPPHMP,?25,"TOTAL PAID BY INSURER FOR DATE: "_ABSPPHMI
+105 IF ABSPQUIT
QUIT
+106 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+107 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""DATE TOTAL: ""_$FNUMBER(ABSPPHMP,"","",2),?40,""TOTAL PAID BY INSURER FOR DATE: ""_$FNUMBER(ABSPPHMI,"","",2)")
+108 IF ABSPQUIT
QUIT
+109 SET ABSPGRNP=ABSPGRNP+ABSPDATP
+110 SET ABSPGRNI=ABSPGRNI+ABSPDATI
End DoDot:1
+111 IF ABSPQUIT
DO ZEND
QUIT
+112 ;W !!,"GRAND TOTAL PRICE: "_ABSPGRNP,?25,"GRAND TOTAL PAID BY INSURER :"_ABSPGRNI
+113 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+114 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: ""_$FNUMBER(ABSPGRNP,"","",2),?40,""GRAND TOTAL INSURER PAID: ""_$FNUMBER(ABSPGRNI,"","",2)")
+115 ;IHS/OIT/SCR 1/4/09 patch 36 close the printer device
DO ZEND
+116 QUIT
CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
+1 NEW DIC,X,Y,ABSPPHRM
+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 ABSPPHRM="ALL"
+8 IF Y>-1
SET ABSPPHRM=$PIECE(Y,"^",1)
+9 QUIT ABSPPHRM
USER() ; PICK WHICH OR ALL NEW PESRSON
+1 ;IHS/OIT/SCR 083109 patch 34
+2 NEW DIC,X,Y,ABSPUSER
+3 SET DIC="^VA(200,"
+4 SET DIC(0)="AEMQVZ"
+5 SET DIC("A")="Please Select a User or leave blank for ALL: "
+6 DO ^DIC
KILL DIC
+7 IF X["^"
QUIT -1
+8 IF Y=-1
SET ABSPUSER="ALL"
+9 IF Y>-1
SET ABSPUSER=$PIECE(Y,"^",1)
+10 QUIT ABSPUSER
DEVSEL ; SELECT DEVICE
+1 NEW ABSPSTOP
+2 SET ABSPSTOP=0
+3 DO ^%ZIS
+4 IF POP
Begin DoDot:1
+5 DO ^%ZIS
+6 QUIT
End DoDot:1
+7 IF $DATA(DUOUT)
Begin DoDot:1
+8 DO ZEND
+9 SET ABSPSTOP=1
+10 QUIT
End DoDot:1
+11 IF ABSPSTOP
QUIT
+12 IF POP
Begin DoDot:1
+13 WRITE "DEVICE UNAVAILABLE"
GOTO DEVSEL
End DoDot:1
+14 QUIT
FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,ABSPTMP,ABSPREJS) ; FIND PAYABLE CLAIMS IN A DATE RANGE, AND THEN DETERMINE IF THEY WERE REJECTED AT ONE TIME...
+1 NEW ABSPDONE,ABSPRDT,ABSPTDAT,ABSPTRXN,ABSPPHM1,APSPTRXI,ABSPRICE,ABSPFND,ABSPRXI,ABSPTRXR,ABSPRXN,ABSPTRXR
+2 NEW ABSPUSR1,ABSPUSRN,ABSPRESP,ABSPPSTN,ABSPCNT
+3 ;S ABSPUSR1=0
+4 SET ABSPRDT=ABSPSTRT-1
+5 SET ABSPDONE=0
+6 SET ABSPRMI=""
+7 FOR
SET ABSPRDT=$ORDER(^ABSPECX("RPT","B",ABSPRDT))
IF ABSPRDT=""!ABSPDONE
QUIT
Begin DoDot:1
+8 IF ABSPRDT>ABSPEND
SET ABSPDONE=1
QUIT
+9 FOR ABSPJ=1:1
SET ABSPRMI=$ORDER(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI))
IF ABSPRMI'=+ABSPRMI
QUIT
Begin DoDot:2
+10 ; NOT A PAYABLE CLAIM
IF $PIECE(^ABSPECX("RPT",ABSPRMI,0),U,6)'=4
QUIT
+11 SET ABSPTRNS=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,3)
+12 SET ABSPPHM1=""
+13 IF ABSPPHRM'="ALL"
Begin DoDot:3
+14 ; NOT SELECTED PHARMACY
IF $PIECE(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPHRM
QUIT
+15 SET ABSPPHM1=ABSPPHRM
+16 QUIT
End DoDot:3
+17 ; SET PHARMACY
IF ABSPPHRM="ALL"
SET ABSPPHM1=$PIECE(^ABSPTL(ABSPTRNS,1),U,7)
+18 IF ABSPPHM1=""
QUIT
+19 SET ABSPUSR1=-1
+20 IF ABSPUSR'="ALL"
Begin DoDot:3
+21 ; NOT SELECTED USER
IF $PIECE(^ABSPTL(ABSPTRNS,0),U,17)'=ABSPUSR
QUIT
+22 SET ABSPUSR1=ABSPUSR
+23 QUIT
End DoDot:3
+24 ; SET USER
IF ABSPUSR="ALL"
SET ABSPUSR1=$PIECE(^ABSPTL(ABSPTRNS,1),U,17)
+25 IF ABSPUSR1=-1
QUIT
+26 ;IHS/OIT/SCR 083109 patch 32 END
+27 SET ABSPTRXI=$PIECE(^ABSPTL(ABSPTRNS,1),U,11)
+28 SET ABSPTRXR=$PIECE(^ABSPTL(ABSPTRNS,1),U,1)
+29 IF ABSPTRXI=""!(ABSPTRXR="")
QUIT
+30 ;NOW WE HAVE A PAYABLE CLAIM...BUT IT ONLY BELONGS ON THIS REPORT IF IT HAS BEEN REJECTED BEFORE
+31 ;SO....WE HAVE TO LOOK AT THE LOG OF TRANSACTIONS FOR THIS PRESCRIPTION BEFORE THE ONE
+32 ;WE HAVE IN OUR HANDS...IF THAT ONE WAS REJECTED, PUT THIS INFO ON THE REPORT
+33 ;Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,""),-1) ;FOUND IN ABSPOS57 AND ABSPOSBB
+34 SET ABSPFND=0
+35 SET ABSPTRN1=""
+36 FOR
SET ABSPTRN1=$ORDER(^ABSPTL("NON-FILEMAN","RXIRXR",ABSPTRXI,ABSPTRXR,ABSPTRN1),-1)
IF ABSPTRN1=""!(ABSPFND=1)
QUIT
Begin DoDot:3
+37 SET ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRN1_",","RESULT WITH REVERSAL")
+38 ;POINTER TO RESPONSE FILE
SET ABSPRESP=$PIECE(^ABSPTL(ABSPTRNS,0),U,5)
+39 ;POSITION IN CLAIM
SET ABSPPSTN=$PIECE(^ABSPTL(ABSPTRNS,0),U,9)
+40 ;I ABSPRWR="E REJECTED" D
+41 IF (ABSPRWR="E REJECTED")!(ABSPRWR="PAPER")
Begin DoDot:4
+42 SET ABSPPAID=0
+43 ;(#509) Total Amount Paid
IF (ABSPRESP'="")&(ABSPPSTN'="")
SET ABSPPAID=$$509^ABSPOS03(ABSPRESP,ABSPPSTN)
+44 SET ABSPFND=1
+45 ;POINTER TO PRESCRIPTION FILE
SET ABSPRXI=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,4)
+46 ;PRESCRIPTION NUMBER
SET ABSPRXN=$PIECE($GET(^PSRX(ABSPRXI,0)),U,1)
+47 ;TRANSACTION LAST UPDATE
SET ABSPTDAT=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,2)
+48 ;REFIL NUMBER
SET ABSPTRXR=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,5)
+49 ;TOTAL PRICE
SET ABSPRICE=$PIECE(^ABSPTL(ABSPTRNS,5),U,5)
+50 ;USER LAST UPDATED - IHS/OIT/SCR 082709 patch 34
SET ABSPUSRI=$PIECE(^ABSPTL(ABSPTRNS,0),U,17)
+51 ;S ABSPUSRI=$P(^ABSPTL(ABSPTRNS,0),U,10)
+52 SET ABSPUSRN=""
+53 ;S ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
+54 IF ABSPUSRI>0
SET ABSPUSRN=$PIECE($GET(^VA(200,ABSPUSRI,0)),"^",1)
+55 SET ABSPTMP(ABSPRDT,ABSPPHM1,ABSPRXI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPUSRN
+56 ;This populates ABSPREJS(n) with code:text format of each rejection for this position in this response
+57 SET ABSPCNT=0
+58 ;POINTER TO RESPONSE FILE for REJECTED transaction
SET ABSPRSP=$PIECE(^ABSPTL(ABSPTRN1,0),U,5)
+59 ;POSITION IN CLAIM for REJECTED transaction
SET ABSPSTN=$PIECE(^ABSPTL(ABSPTRN1,0),U,9)
+60 IF $GET(ABSPRSP)'=""
Begin DoDot:5
+61 ;FOR EACH REJECTION CODE AND REASON associated to the REJECTED TRANSACTION, add it to an array
+62 DO REJTEXT^ABSPOS03(ABSPRSP,ABSPSTN,.ABSPREJS)
+63 FOR
SET ABSPCNT=$ORDER(ABSPREJS(ABSPCNT))
IF (ABSPCNT=""!ABSPQUIT)
QUIT
Begin DoDot:6
+64 SET ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPRXI,ABSPCNT,"CODE")=$PIECE(ABSPREJS(ABSPCNT),":",1)
+65 SET ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPRXI,ABSPCNT,"REASON")=$PIECE(ABSPREJS(ABSPCNT),":",2)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+66 QUIT
PRHDR(ABSPSTRT,ABSPEND) ; PRINT HEADER
+1 NEW ABSPFEDT,ABSPFBDT
+2 USE IO
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 !,?19,"Pharmacy Point of Sale Collection Productivity Report"
+10 WRITE !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT
+11 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
ZEND ;Close the device that was opened
+1 DO ^%ZISC
+2 QUIT
