ABSPOSRY ;IHS/OIT/SCR - COLLECTION PRODUCTIVITY REPORT ;/IHS/OIT/CNI/RAN REWRITTEN TO NOT USE REPORT MASTER
;;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,ABSPREJS,Y,X1,X2,ABSPEND,ABSPSTRT,ABSPDAT,ABSPPRXI,ABSPRJCT
N ABSPPHMP,ABSPPHMI,ABSPDATP,ABSPDATI,ABSPGRNP,ABSPGRNI,ABSPUSR,ABSPCNT,STARTIME,STOPTIME,ABSPSDAT
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
;D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,.ABSPTMP) IHS/OIT/SCR 083109 patch 34
S STARTIME=$H
D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,.ABSPREJS)
S STOPTIME=$H
S ^TMP("ABSPOSRY-RUNLOG",$J,STARTIME)=ABSPSTRT_"^"_ABSPEND_"^"_($P(STOPTIME,",",2)-$P(STARTIME,",",2))
I $O(^TMP("ABSPOSRY",$J,""))="" 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(^TMP("ABSPOSRY",$J,ABSPSDAT)) Q:(ABSPSDAT="")!(ABSPQUIT) D
.M ABSPTMP(ABSPSDAT)=^TMP("ABSPOSRY",$J,ABSPSDAT)
.S ABSPDATP=0,ABSPDATI=0 ;IHS/OIT/SCR 082709 patch 34
.S ABSPPHRM=""
.S Y=$P(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
..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
.K ABSPTMP(ABSPSDAT)
.Q:ABSPQUIT
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,POP
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,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,ABSPIRME,ABSPPRMI
N ABSPUSR1,ABSPUSRN,ABSPRESP,ABSPPSTN,ABSPCNT,ABSP1LTP,ABSPRWR,ABSPTRN1,ABSPFND,ABSPCLMI,ABSPCLMS,ABSPIRMI,ABSPTRNS
S ABSPDONE=0
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("ABSPOSRY",$J,$P(ABSPRDT,"."))=""
.S ABSPPRMI=""
.F S ABSPPRMI=$O(^PSRX("AL",ABSPRDT,ABSPPRMI)) Q:ABSPPRMI="" D
..S ABSPFND=0
..S ABSPIRMI=ABSPPRMI
..S ABSPIRME=ABSPPRMI_".99999999"
..F S ABSPIRMI=$O(^ABSPTL("B",ABSPIRMI)) Q:(ABSPIRMI>ABSPIRME)!(ABSPIRMI="")!(ABSPFND) D
...Q:+$E($P(ABSPIRMI,".",2))>1 ;ONLY PROCESS PRIMARY NOT SECONDARY OR TERTIARY
...S ABSPTRNS=""
...F S ABSPTRNS=$O(^ABSPTL("B",ABSPIRMI,ABSPTRNS),-1) Q:(ABSPTRNS="")!(ABSPFND) D
....; WE ONLY WANT PAID CLAIMS HERE
....S ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRNS_",","RESULT WITH REVERSAL")
....S ABSP1LTP=^ABSPTL(ABSPTRNS,1)
....S ABSPUSR1=$P(ABSP1LTP,U,17)
....I (ABSPUSR'="ALL"),(ABSPUSR1'=ABSPUSR) Q ; NOT SELECTED USER
....S ABSPPHM1=$P(ABSP1LTP,U,7) ; SET PHARMACY
....I (ABSPPHRM'="ALL")&&(ABSPPHM1'=ABSPPHRM) Q ; NOT SELECTED PHARMACY
....I ABSPPHM1="" Q
....I ABSPRWR'="E PAYABLE" 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
....S ABSPTRN1=ABSPTRNS
....F S ABSPTRN1=$O(^ABSPTL("B",ABSPIRMI,ABSPTRN1),-1) Q:(ABSPTRN1="")!(ABSPFND) D
.....S ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRN1_",","RESULT WITH REVERSAL")
.....I (ABSPRWR="E REJECTED")!(ABSPRWR="PAPER") D
......S ABSPFND=1
......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^ZRANOSR5(ABSPRSMI,$P(ABSPIRMI,".")) ;IHS/OIT/CNI/SCR patch 40 - commentd out call to non-namespaced routine
......Q:DO=""
......Q:$D(ABSPCLMS(ABSPIRMI))
......S ABSPTINS=$P(ABSP1LTP,U,6)
......S ABSPTRXR=$P(ABSP1LTP,U,1)
......S ABSPTDAT=$P($P(ABSPTLTP,U,8),".",1)
......S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5) ;TOTAL PRICE
......S ABSPPAID=$$509^ABSPOS03(ABSPRSMI,DO)
......S ABSPUSRI=$P(ABSPTLTP,U,17) ;USER LAST UPDATED - IHS/OIT/SCR 082709 patch 34
......S ABSPUSRN=""
......S:ABSPUSRI>0 ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
......;IHS/OIT/SCR 082109 START changes patch 34
......S ABSPCLMS(ABSPIRMI)=""
......;S ^TMP("CPR-RPT",$J,ABSPRDT,ABSPPHM1,ABSPPRMI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPUSRN
......S ^TMP("ABSPOSRY",$J,ABSPRDT,ABSPPHM1,ABSPPRMI)=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
.......;BREAK
.......K ABSPREJS
.......D REJTEXT^ABSPOS03(ABSPRSP,ABSPSTN,.ABSPREJS)
.......F S ABSPCNT=$O(ABSPREJS(ABSPCNT)) Q:(ABSPCNT="") D
........S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPPRMI,ABSPCNT,"CODE")=$P(ABSPREJS(ABSPCNT),":",1)
........S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPPRMI,ABSPCNT,"REASON")=$P(ABSPREJS(ABSPCNT),":",2)
....I 'ABSPFND S ABSPFND=1 ;DONT DO THIS HOLE LOOP AGAIN FOR THE ABSPTRNS
Q
PRHDR(ABSPSTRT,ABSPEND) ; PRINT HEADER
N ABSPFEDT,ABSPFBDT
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
;K ^TMP("CPR-RPT",$J)
K ^TMP("ABSPOSRY",$J)
D ^%ZISC
Q
ABSPOSRY ;IHS/OIT/SCR - COLLECTION PRODUCTIVITY REPORT ;/IHS/OIT/CNI/RAN REWRITTEN TO NOT USE REPORT MASTER
+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,ABSPREJS,Y,X1,X2,ABSPEND,ABSPSTRT,ABSPDAT,ABSPPRXI,ABSPRJCT
+2 NEW ABSPPHMP,ABSPPHMI,ABSPDATP,ABSPDATI,ABSPGRNP,ABSPGRNI,ABSPUSR,ABSPCNT,STARTIME,STOPTIME,ABSPSDAT
+3 SET ABSPDONE=0
+4 SET ABSPQUIT=0
+5 FOR
IF ABSPDONE=1
QUIT
Begin DoDot:1
+6 SET ABSPSTRT=$$BDT()
+7 IF ABSPSTRT=-1
Begin DoDot:2
+8 SET ABSPQUIT=1
+9 SET ABSPDONE=1
+10 QUIT
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
+16 QUIT
End DoDot:2
+17 IF ABSPQUIT
QUIT
+18 IF ABSPSTRT<0
SET ABSPDONE=1
QUIT
+19 IF ABSPEND<0
SET ABSPDONE=1
QUIT
+20 SET X2=ABSPSTRT
SET X1=ABSPEND
DO ^%DTC
+21 IF X<0
DO EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")
+22 IF X>=0
SET ABSPDONE=1
+23 QUIT
End DoDot:1
+24 IF ABSPQUIT
QUIT
+25 SET ABSPPHRM=$$CLNC()
+26 IF ABSPPHRM=-1
QUIT
+27 SET ABSPUSR=$$USER()
+28 DO ^XBCLS
+29 ;D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,.ABSPTMP) IHS/OIT/SCR 083109 patch 34
+30 SET STARTIME=$HOROLOG
+31 DO FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,.ABSPREJS)
+32 SET STOPTIME=$HOROLOG
+33 SET ^TMP("ABSPOSRY-RUNLOG",$JOB,STARTIME)=ABSPSTRT_"^"_ABSPEND_"^"_($PIECE(STOPTIME,",",2)-$PIECE(STARTIME,",",2))
+34 IF $ORDER(^TMP("ABSPOSRY",$JOB,""))=""
Begin DoDot:1
+35 WRITE !," ****NO RECORDS FOUND FOR DATE RANGE***",!!
+36 NEW DIR
+37 SET DIR(0)="Y"
+38 SET DIR("A")="PRINT ANYWAY"
+39 DO ^DIR
+40 IF Y'=1
SET ABSPQUIT=1
+41 QUIT
End DoDot:1
+42 IF ABSPQUIT
QUIT
+43 DO DEVSEL
+44 DO PRHDR(ABSPSTRT,ABSPEND)
+45 SET ABSPSDAT=""
+46 ;IHS/OIT/SCR 082709 patch 34
SET ABSPGRNP=0
SET ABSPGRNI=0
+47 FOR
SET ABSPSDAT=$ORDER(^TMP("ABSPOSRY",$JOB,ABSPSDAT))
IF (ABSPSDAT="")!(ABSPQUIT)
QUIT
Begin DoDot:1
+48 MERGE ABSPTMP(ABSPSDAT)=^TMP("ABSPOSRY",$JOB,ABSPSDAT)
+49 ;IHS/OIT/SCR 082709 patch 34
SET ABSPDATP=0
SET ABSPDATI=0
+50 SET ABSPPHRM=""
+51 SET Y=$PIECE(ABSPSDAT,".")
+52 DO DD^%DT
+53 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+54 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!?10,""RELEASED DATE: ""_Y")
+55 IF ABSPQUIT
QUIT
+56 FOR
SET ABSPPHRM=$ORDER(ABSPTMP(ABSPSDAT,ABSPPHRM))
IF (ABSPPHRM="")!(ABSPQUIT)
QUIT
Begin DoDot:2
+57 SET ABSPPHMP=0
SET ABSPPHMI=0
+58 ;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen, use paging
+59 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?15,""PHARMACY: ""_$P($G(^ABSP(9002313.56,ABSPPHRM,0)),U,1)")
+60 IF ABSPQUIT
QUIT
+61 IF ABSPUSR="ALL"
SET ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ALL""")
+62 IF ABSPQUIT
QUIT
+63 IF ABSPUSR'="ALL"
SET ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ""_$P($G(^VA(200,ABSPUSR,0)),U,1)")
+64 IF ABSPQUIT
QUIT
+65 SET ABSPPRXI=""
+66 FOR
SET ABSPPRXI=$ORDER(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI))
IF (ABSPPRXI="")!(ABSPQUIT)
QUIT
Begin DoDot:3
+67 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+68 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""RX #/REFILL: `""_ABSPPRXI_""/""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,1)")
+69 IF ABSPQUIT
QUIT
+70 SET Y=$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",2)
DO DD^%DT
+71 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+72 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?5,""TRANSACTION DATE: ""_Y,?40,""RECOVERED BY: ""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,5)")
+73 IF ABSPQUIT
QUIT
+74 ;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
+75 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+76 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)")
+77 IF ABSPQUIT
QUIT
+78 SET ABSPPHMP=ABSPPHMP+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",3)
+79 SET ABSPPHMI=ABSPPHMI+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",4)
+80 ;PRINT OUT REJECTION REASONS FOR THE REJECTION BEFORE THE PAID TXN
+81 SET ABSPCNT=0
+82 FOR
SET ABSPCNT=$ORDER(ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT))
IF (ABSPCNT="")!(ABSPQUIT)
QUIT
Begin DoDot:4
+83 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+84 SET ABSPQUIT=$$WRITE^ABSPOSUU("!?15,ABSPCNT_"". REJECTION CODE: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""CODE"")")
+85 IF ABSPQUIT
QUIT
+86 SET ABSPQUIT=$$WRITE^ABSPOSUU("?20,""REASON: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""REASON"")")
+87 IF ABSPQUIT
QUIT
End DoDot:4
+88 IF ABSPQUIT
QUIT
+89 ;PRINT OUT FIELDS AND VALUES OF ENTRIES IN ABSP NCPDP OVERRIDE FILE FOR THIS TXN
+90 ;W !!
+91 ;S ABSPCNT=0
+92 ;F S ABSPCNT=$O(ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT)) Q:ABSPCNT="" D
+93 ;.W !,?5,"MOST RECENT OVERIDE FIELD: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"FIELD")
+94 ;.W !,?15,"CHANGED TO: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"NEW VALUE")
End DoDot:3
+95 IF ABSPQUIT
QUIT
+96 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+97 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""PHARMACY TOTAL ""_$FNUMBER(ABSPPHMP,"","",2),?40,""INSURER PAID: ""_$FNUMBER(ABSPPHMI,"","",2)")
+98 IF ABSPQUIT
QUIT
+99 SET ABSPDATP=ABSPDATP+ABSPPHMP
+100 SET ABSPDATI=ABSPDATI+ABSPPHMI
+101 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""DATE TOTAL: ""_$FNUMBER(ABSPPHMP,"","",2),?40,""TOTAL PAID BY INSURER FOR DATE: ""_$FNUMBER(ABSPPHMI,"","",2)")
+102 IF ABSPQUIT
QUIT
+103 SET ABSPGRNP=ABSPGRNP+ABSPDATP
+104 SET ABSPGRNI=ABSPGRNI+ABSPDATI
End DoDot:2
+105 KILL ABSPTMP(ABSPSDAT)
+106 IF ABSPQUIT
QUIT
End DoDot:1
+107 IF ABSPQUIT
DO ZEND
QUIT
+108 ;W !!,"GRAND TOTAL PRICE: "_ABSPGRNP,?25,"GRAND TOTAL PAID BY INSURER :"_ABSPGRNI
+109 ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
+110 SET ABSPQUIT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: ""_$FNUMBER(ABSPGRNP,"","",2),?40,""GRAND TOTAL INSURER PAID: ""_$FNUMBER(ABSPGRNI,"","",2)")
+111 ;IHS/OIT/SCR 1/4/09 patch 36 close the printer device
DO ZEND
+112 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,POP
+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,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,ABSPIRME,ABSPPRMI
+2 NEW ABSPUSR1,ABSPUSRN,ABSPRESP,ABSPPSTN,ABSPCNT,ABSP1LTP,ABSPRWR,ABSPTRN1,ABSPFND,ABSPCLMI,ABSPCLMS,ABSPIRMI,ABSPTRNS
+3 SET ABSPDONE=0
+4 SET ABSPRDT=ABSPSTRT
+5 SET ABSPEND=ABSPEND_".99999999"
+6 SET ABSPDONE=0
+7 FOR
SET ABSPRDT=$ORDER(^PSRX("AL",ABSPRDT))
IF (ABSPRDT="")!(ABSPDONE)!(+ABSPRDT=0)
QUIT
Begin DoDot:1
+8 IF ABSPRDT>ABSPEND
SET ABSPDONE=1
QUIT
+9 ;S ^TMP("ABSPOSRY",$J,$P(ABSPRDT,"."))=""
+10 SET ABSPPRMI=""
+11 FOR
SET ABSPPRMI=$ORDER(^PSRX("AL",ABSPRDT,ABSPPRMI))
IF ABSPPRMI=""
QUIT
Begin DoDot:2
+12 SET ABSPFND=0
+13 SET ABSPIRMI=ABSPPRMI
+14 SET ABSPIRME=ABSPPRMI_".99999999"
+15 FOR
SET ABSPIRMI=$ORDER(^ABSPTL("B",ABSPIRMI))
IF (ABSPIRMI>ABSPIRME)!(ABSPIRMI="")!(ABSPFND)
QUIT
Begin DoDot:3
+16 ;ONLY PROCESS PRIMARY NOT SECONDARY OR TERTIARY
IF +$EXTRACT($PIECE(ABSPIRMI,".",2))>1
QUIT
+17 SET ABSPTRNS=""
+18 FOR
SET ABSPTRNS=$ORDER(^ABSPTL("B",ABSPIRMI,ABSPTRNS),-1)
IF (ABSPTRNS="")!(ABSPFND)
QUIT
Begin DoDot:4
+19 ; WE ONLY WANT PAID CLAIMS HERE
+20 SET ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRNS_",","RESULT WITH REVERSAL")
+21 SET ABSP1LTP=^ABSPTL(ABSPTRNS,1)
+22 SET ABSPUSR1=$PIECE(ABSP1LTP,U,17)
+23 ; NOT SELECTED USER
IF (ABSPUSR'="ALL")
IF (ABSPUSR1'=ABSPUSR)
QUIT
+24 ; SET PHARMACY
SET ABSPPHM1=$PIECE(ABSP1LTP,U,7)
+25 ; NOT SELECTED PHARMACY
IF (ABSPPHRM'="ALL")&&(ABSPPHM1'=ABSPPHRM)
QUIT
+26 IF ABSPPHM1=""
QUIT
+27 IF ABSPRWR'="E PAYABLE"
QUIT
+28 ;NOW WE HAVE A PAYABLE CLAIM...BUT IT ONLY BELONGS ON THIS REPORT IF IT HAS BEEN REJECTED BEFORE
+29 ;SO....WE HAVE TO LOOK AT THE LOG OF TRANSACTIONS FOR THIS PRESCRIPTION BEFORE THE ONE
+30 ;WE HAVE IN OUR HANDS...IF THAT ONE WAS REJECTED, PUT THIS INFO ON THE REPORT
+31 SET ABSPTRN1=ABSPTRNS
+32 FOR
SET ABSPTRN1=$ORDER(^ABSPTL("B",ABSPIRMI,ABSPTRN1),-1)
IF (ABSPTRN1="")!(ABSPFND)
QUIT
Begin DoDot:5
+33 SET ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRN1_",","RESULT WITH REVERSAL")
+34 IF (ABSPRWR="E REJECTED")!(ABSPRWR="PAPER")
Begin DoDot:6
+35 SET ABSPFND=1
+36 SET ABSPTLTP=^ABSPTL(ABSPTRNS,0)
+37 ;Response reference
SET ABSPRSMI=$PIECE(ABSPTLTP,U,5)
+38 ;Claim Reference
SET ABSPCLMI=$PIECE(ABSPTLTP,U,4)
+39 IF (ABSPRSMI="")!(ABSPCLMI="")
QUIT
+40 ;Position on claim(and response)
SET DO=$PIECE(ABSPTLTP,U,9)
+41 ;I '$D(^ABSPR(ABSPRSMI,1000,DO)) S DO=$$GETDO^ZRANOSR5(ABSPRSMI,$P(ABSPIRMI,".")) ;IHS/OIT/CNI/SCR patch 40 - commentd out call to non-namespaced routine
+42 IF DO=""
QUIT
+43 IF $DATA(ABSPCLMS(ABSPIRMI))
QUIT
+44 SET ABSPTINS=$PIECE(ABSP1LTP,U,6)
+45 SET ABSPTRXR=$PIECE(ABSP1LTP,U,1)
+46 SET ABSPTDAT=$PIECE($PIECE(ABSPTLTP,U,8),".",1)
+47 ;TOTAL PRICE
SET ABSPRICE=$PIECE(^ABSPTL(ABSPTRNS,5),U,5)
+48 SET ABSPPAID=$$509^ABSPOS03(ABSPRSMI,DO)
+49 ;USER LAST UPDATED - IHS/OIT/SCR 082709 patch 34
SET ABSPUSRI=$PIECE(ABSPTLTP,U,17)
+50 SET ABSPUSRN=""
+51 IF ABSPUSRI>0
SET ABSPUSRN=$PIECE($GET(^VA(200,ABSPUSRI,0)),"^",1)
+52 ;IHS/OIT/SCR 082109 START changes patch 34
+53 SET ABSPCLMS(ABSPIRMI)=""
+54 ;S ^TMP("CPR-RPT",$J,ABSPRDT,ABSPPHM1,ABSPPRMI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPUSRN
+55 SET ^TMP("ABSPOSRY",$JOB,ABSPRDT,ABSPPHM1,ABSPPRMI)=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:7
+61 ;FOR EACH REJECTION CODE AND REASON associated to the REJECTED TRANSACTION, add it to an array
+62 ;BREAK
+63 KILL ABSPREJS
+64 DO REJTEXT^ABSPOS03(ABSPRSP,ABSPSTN,.ABSPREJS)
+65 FOR
SET ABSPCNT=$ORDER(ABSPREJS(ABSPCNT))
IF (ABSPCNT="")
QUIT
Begin DoDot:8
+66 SET ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPPRMI,ABSPCNT,"CODE")=$PIECE(ABSPREJS(ABSPCNT),":",1)
+67 SET ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPPRMI,ABSPCNT,"REASON")=$PIECE(ABSPREJS(ABSPCNT),":",2)
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
+68 ;DONT DO THIS HOLE LOOP AGAIN FOR THE ABSPTRNS
IF 'ABSPFND
SET ABSPFND=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+69 QUIT
PRHDR(ABSPSTRT,ABSPEND) ; PRINT HEADER
+1 NEW ABSPFEDT,ABSPFBDT
+2 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 ;K ^TMP("CPR-RPT",$J)
+2 KILL ^TMP("ABSPOSRY",$JOB)
+3 DO ^%ZISC
+4 QUIT
