ABSPOSEX ; IHS/OIT/SCR - PATIENT EXPENSE gereration routine ; [ 10/24/2005 10:09:07 AM ]
;;1.0;PHARMACY POINT OF SALE;**30,34,36**;JUN 21, 2001;Build 38
;
Q
MAIN ;EP
N ABSPPNAM,ABSPPIEN,ABSPPINF,ABSPPHRM,ABSPRXDT,ABSPARRY,ABSPDOB,ABSPDONE,ABSPTMP,ABSPPHRN,ABSPEND
N ABSPPDOB,ABSPQUIT,ABSPSDAT,ABSPSDAT,ABSPSTRT,ABSPEND,ABSPPRMI,ABSPFROM,ABSPTO,ABSPPROV
N ABSPDTOT,ABSPDINS,ABSPDDUE,ABSPGTOT,ABSPGINS,ABSPGDUE ;IHS/OIT/SCR 082509 patch 34
N IO ;IHS/OIT/SCR 011110 patch 36
D AUTO^ABSPOSM1()
S ABSPDONE=0
S ABSPQUIT=0
S ABSPPINF=$$GETPAT
Q:ABSPPINF<1
S ABSPPIEN=$P(ABSPPINF,U,1) ;VA(200 patient IEN
S ABSPPNAM=$P(ABSPPINF,U,2) ;VA(200 patient name
S ABSPPDOB=$$DOB^AUPNPAT(ABSPPIEN,"E")
S ABSPPHRN=$$HRN^AUPNPAT(ABSPPIEN,DUZ(2))
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
D DEVSEL ;IHS/OIT/SCR 011110 patch 36 NEEDS TO COME BEFORE FIND TO KEEP LOCAL VARIABLES
D FIND(ABSPSTRT,ABSPEND,ABSPPIEN,.ABSPTMP)
S ABSPSDAT=""
S Y=ABSPSTRT D DD^%DT S ABSPFROM=Y
S Y=ABSPEND D DD^%DT S ABSPTO=Y
;D DEVSEL ;IHS/OIT/SCR 011110 patch 36 start changes
I $O(ABSPTMP(""))="" D Q
.D ^%ZISC
.W !,"NO TRANSACTIONS FOUND FOR THIS DATE RANGE"
.Q
U IO
W @IOF ;IHS/OIT/SCR 011110 patch 36 end changes
W !,"PATIENT: "_ABSPPNAM_" DOB: "_ABSPPDOB_" HRN: "_ABSPPHRN
W !?15," PHARMACY RELEASE DATES FROM "_ABSPFROM_" TO "_ABSPTO
S ABSPGTOT=0,ABSPGINS=0,ABSPGDUE=0 ;IHS/OIT/SCR 082509 patch 34
F S ABSPSDAT=$O(ABSPTMP(ABSPSDAT)) Q:ABSPSDAT="" D
.Q:ABSPTMP(ABSPSDAT)=""
.S Y=ABSPSDAT D DD^%DT
.W !!?10,"RELEASE DATE: "_Y
.S ABSPPHRM=""
.F S ABSPPHRM=$O(ABSPTMP(ABSPSDAT,ABSPPHRM)) Q:ABSPPHRM="" D
..S ABSPDTOT=0,ABSPDINS=0,ABSPDDUE=0 ;IHS/OIT/SCR 082509 patch 34
..W !!?8,"PHARMACY: "_$P($G(^ABSP(9002313.56,ABSPPHRM,0)),"^",1)
..S ABSPPRMI=""
..F S ABSPPRMI=$O(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI)) Q:ABSPPRMI="" D
...W !!,"RX #/REFILL: `"_ABSPPRMI_"/"_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),U,1)
...S Y=$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",2) D DD^%DT
...W !?0,"TRANSACTION DATE: "_Y,?40,"TRANSACTION TYPE: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",4)
...W !?5,"DRUG NAME: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",5),?50,"NDC#: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",6)
...W !?5,"QTY: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",9),?50,"D/S: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",10)
...S ABSPPROV=$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",7)
...W !?5,"PROVIDER NAME: "_$P(^VA(200,ABSPPROV,0),"^",1),?50,"PROVIDER NPI#: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",8)
...W !?0,"TOTAL PRICE: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",11),?25,"INSURER PAID: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",12),?53,"AMOUNT DUE: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",13)
...;IHS/OIT/SCR 082509 patch 34 START CHANGES
...S ABSPDTOT=ABSPDTOT+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",11)
...S ABSPDINS=ABSPDINS+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",12)
...S ABSPDDUE=ABSPDDUE+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",13)
..Q
.W !!,?0,"TOTAL FOR DATE: "_ABSPDTOT,?25,"INS PAID FOR DATE: "_ABSPDINS,?53,"DUE FOR DATE: "_ABSPDDUE
.S ABSPGTOT=ABSPGTOT+ABSPDTOT
.S ABSPGINS=ABSPGINS+ABSPDINS
.S ABSPGDUE=ABSPGDUE+ABSPDDUE
.Q
;IHS/OIT/SCR 082509 patch 34 END CHANGES
W !!,?0,"GRAND TOTAL: "_ABSPGTOT,?25,"TOTAL INS PAID: "_ABSPGINS,?53,"TOTAL DUE: "_ABSPGDUE
D ^%ZISC ;IHS/OIT/SCR 1/4/10 patch 36 close the device that was opened
Q
FIND(ABSPSTRT,ABSPEND,ABSPPIEN,ABSPTMP) ; FIND PRESCRIPTIONS FOR THIS PATIENT IN A DATE RANGE
N ABSPDONE,ABSPRDT,ABSPPHRM,ABSPRMI,ABSPCTYP,ABSPDAT,ABSPTRXI,ABSPDRGP,ABSPDRGN,ABSPNDC,ABSPPROV
N ABSPPNPI,ABSPQTY,ABSPDAYS,ABSPCPAY,ABSPDAYS,ABSPTDAT,ABSPDONE,ABSPCTYN,ABSPTPAT,ABSPTRNS,ABSPRXR,ABSPRXN
N ABSPRESP,ABSPPSTN,ABSPNET,RESP
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 S ABSPRMI=$O(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI)) Q:ABSPRMI'=+ABSPRMI D
..S ABSPTRNS=$P(^ABSPECX("RPT",ABSPRMI,0),U,3)
..Q:ABSPTRNS=""
..S ABSPTPAT=$P(^ABSPTL(ABSPTRNS,0),U,6) ;TRANSACTION PATIENT
..Q:ABSPTPAT'=ABSPPIEN ;NOT SELECTED PATIENT
..S ABSPPHRM=$P(^ABSPTL(ABSPTRNS,1),U,7)
..S:ABSPPHRM="" ABSPPHRM=0 ;IHS/OIT/SCR 010410 patch 36
..S ABSPCTYP=$P(^ABSPECX("RPT",ABSPRMI,0),U,6)
..;S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5) IHS/OIT/SCR 010420 patch 36
..S ABSPRICE=$P($G(^ABSPTL(ABSPTRNS,5)),U,5)
..S ABSPRESP=$P(^ABSPTL(ABSPTRNS,0),U,5) ;POINTER TO RESPONSE FILE
..S ABSPPSTN=$P(^ABSPTL(ABSPTRNS,0),U,9) ;POSITION IN CLAIM
..S ABSPTDAT=$P(^ABSPECX("RPT",ABSPRMI,0),U,2) ;TRANSACTION LAST UPDATE
..S ABSPTRXI=$P(^ABSPECX("RPT",ABSPRMI,0),U,4) ;POINTER TO PRESCRIPTION FILE
..S ABSPCTYN=""
..S ABSPNET=0
..I ABSPCTYP=1 D
...S ABSPCTYN="REJECTED"
...S ABSPPAID=0
...S ABSPCPAY=ABSPRICE
...Q
..I ABSPCTYP=4 D
...S ABSPCTYN="E PAYABLE"
...Q:ABSPRESP=""
...Q:ABSPPSTN=""
...S ABSPCPAY=$$505^ABSPOS03(ABSPRESP,ABSPPSTN) ;PATIENT PAY AMOUNT
...S ABSPPAID=$$509^ABSPOS03(ABSPRESP,ABSPPSTN) ;(#509) Total Amount Paid
...Q
..I ABSPCTYP=9 D
...S ABSPCTYN="PAPER"
...S ABSPPAID=0
...S ABSPCPAY=ABSPRICE
...Q
..Q:ABSPCTYN=""
..S ABSPTRXR=$P(^ABSPECX("RPT",ABSPRMI,0),U,5) ;REFILL NUMBER
..S ABSPTRXN=$P($G(^PSRX(ABSPTRXI,0)),U,1) ;EXTERNAL PRESCRIPTION NUMBER
..S ABSPDRGP=$P($G(^PSRX(ABSPTRXI,0)),U,6) ;POINTER TO DRUG FILE
..S ABSPDRGN=$P(^PSDRUG(ABSPDRGP,0),U,1) ;DRUG NAME
..S ABSPDSYN=$P(^PSDRUG(ABSPDRGP,0),U,1) ;DRUG NAME
..S ABSPNDC=$P(^ABSPTL(ABSPTRNS,1),U,2) ;NDC NUMBER
..S ABSPPROV=$P(^PSRX(ABSPTRXI,0),U,4) ;POINTER TO NEW PERSON FILE (PROVIDER)
..S ABSPPNPI=$P($$NPI^XUSNPI("Individual_ID",ABSPPROV),U) ;PROVIDER NPI
..S ABSPQTY=$P(^PSRX(ABSPTRXI,0),U,7) ;PRESCRIPTION QUANTITY
..S ABSPDAYS=$P(^PSRX(ABSPTRXI,0),U,8) ;PRESCRIPTION DAYS SUPPLY
..S ABSPCPAY=$FNUMBER(ABSPCPAY,"",2)
..S ABSPPAID=$FNUMBER(ABSPPAID,"",2)
..S ABSPRICE=$FNUMBER(ABSPRICE,"",2)
..S ABSPTMP(ABSPRDT)=1
..S ABSPTMP(ABSPRDT,ABSPPHRM,ABSPTRXI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPCTYP_"^"_ABSPCTYN_"^"_ABSPDRGN_"^"_ABSPNDC_"^"_ABSPPROV_"^"_ABSPPNPI_"^"_ABSPQTY_"^"_ABSPDAYS_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPCPAY
..Q
.Q
Q
GETPAT() ;Prompt the user for which patient they would like to generate an E1 for
N ABSPDUZ2,ABSPDONE,Y,DIC
S ABSPDONE=0 ;set to one when we are done prompting
S Y=0
S ABSPDUZ2=+$G(DUZ(2)),DUZ(2)=0
S DIC=2,DIC(0)="AEMQZ"
S DIC("A")="Generate A patient expense report for which Patient? "
F D Q:ABSPDONE
. D ^DIC
. S:(($G(DUOUT))!($G(DTOUT))!(Y>0)!(X="")) ABSPDONE=1
K DIC
S DUZ(2)=ABSPDUZ2
Q Y
GETPHARM() ;when more than one pharmacy is set up for this site, prompt
; for which one to use
N ABSPHARM,ABSPHLDP,Y,ABSPDONE,ABSPHCNT,DIC
S (ABSPHCNT,ABSPDONE,PHARM,Y)=0 ;initialize beginning variables
F S ABSPHARM=$O(^ABSP(9002313.56,PHARM)) Q:'+ABSPHARM D
. S ABSPHCNT=ABSPHCNT+1
. S:ABSPHCNT=1 ABSPHLDP=ABSPHARM
Q:ABSPHCNT=1 ABSPHLDP
W !!
S DIC=9002313.56,DIC(0)="AEMQZ"
S DIC("B")=$P($G(^ABSP(9002313.56,ABSPHLDP,0)),U)
S DIC("A")="Please specify the pharmacy: "
F D Q:ABSPDONE
. D ^DIC
. S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) ABSPDONE=1
Q +Y
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
DEVSEL ; SELECT DEVICE
N ABSPSTOP
S ABSPSTOP=0
D ^%ZIS
I POP D
.D ^%ZIS
.Q
I $D(DUOUT) D
.D ^%ZISC
.S ABSPSTOP=1
.Q
Q:ABSPSTOP
I POP D
.W "DEVICE UNAVAILABLE" G DEVSEL
Q
ZEND ; CLOSE DEVICE
D ^%ZISC
Q
ABSPOSEX ; IHS/OIT/SCR - PATIENT EXPENSE gereration routine ; [ 10/24/2005 10:09:07 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**30,34,36**;JUN 21, 2001;Build 38
+2 ;
+3 QUIT
MAIN ;EP
+1 NEW ABSPPNAM,ABSPPIEN,ABSPPINF,ABSPPHRM,ABSPRXDT,ABSPARRY,ABSPDOB,ABSPDONE,ABSPTMP,ABSPPHRN,ABSPEND
+2 NEW ABSPPDOB,ABSPQUIT,ABSPSDAT,ABSPSDAT,ABSPSTRT,ABSPEND,ABSPPRMI,ABSPFROM,ABSPTO,ABSPPROV
+3 ;IHS/OIT/SCR 082509 patch 34
NEW ABSPDTOT,ABSPDINS,ABSPDDUE,ABSPGTOT,ABSPGINS,ABSPGDUE
+4 ;IHS/OIT/SCR 011110 patch 36
NEW IO
+5 DO AUTO^ABSPOSM1()
+6 SET ABSPDONE=0
+7 SET ABSPQUIT=0
+8 SET ABSPPINF=$$GETPAT
+9 IF ABSPPINF<1
QUIT
+10 ;VA(200 patient IEN
SET ABSPPIEN=$PIECE(ABSPPINF,U,1)
+11 ;VA(200 patient name
SET ABSPPNAM=$PIECE(ABSPPINF,U,2)
+12 SET ABSPPDOB=$$DOB^AUPNPAT(ABSPPIEN,"E")
+13 SET ABSPPHRN=$$HRN^AUPNPAT(ABSPPIEN,DUZ(2))
+14 FOR
IF ABSPDONE=1
QUIT
Begin DoDot:1
+15 SET ABSPSTRT=$$BDT()
+16 IF ABSPSTRT=-1
Begin DoDot:2
+17 SET ABSPQUIT=1
+18 SET ABSPDONE=1
+19 QUIT
End DoDot:2
+20 IF ABSPQUIT
QUIT
+21 SET ABSPEND=$$EDT()
+22 IF ABSPEND=-1
Begin DoDot:2
+23 SET ABSPQUIT=1
+24 SET ABSPDONE=1
+25 QUIT
End DoDot:2
+26 IF ABSPQUIT
QUIT
+27 IF ABSPSTRT<0
SET ABSPDONE=1
QUIT
+28 IF ABSPEND<0
SET ABSPDONE=1
QUIT
+29 SET X2=ABSPSTRT
SET X1=ABSPEND
DO ^%DTC
+30 IF X<0
DO EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")
+31 IF X>=0
SET ABSPDONE=1
+32 QUIT
End DoDot:1
+33 IF ABSPQUIT
QUIT
+34 ;IHS/OIT/SCR 011110 patch 36 NEEDS TO COME BEFORE FIND TO KEEP LOCAL VARIABLES
DO DEVSEL
+35 DO FIND(ABSPSTRT,ABSPEND,ABSPPIEN,.ABSPTMP)
+36 SET ABSPSDAT=""
+37 SET Y=ABSPSTRT
DO DD^%DT
SET ABSPFROM=Y
+38 SET Y=ABSPEND
DO DD^%DT
SET ABSPTO=Y
+39 ;D DEVSEL ;IHS/OIT/SCR 011110 patch 36 start changes
+40 IF $ORDER(ABSPTMP(""))=""
Begin DoDot:1
+41 DO ^%ZISC
+42 WRITE !,"NO TRANSACTIONS FOUND FOR THIS DATE RANGE"
+43 QUIT
End DoDot:1
QUIT
+44 USE IO
+45 ;IHS/OIT/SCR 011110 patch 36 end changes
WRITE @IOF
+46 WRITE !,"PATIENT: "_ABSPPNAM_" DOB: "_ABSPPDOB_" HRN: "_ABSPPHRN
+47 WRITE !?15," PHARMACY RELEASE DATES FROM "_ABSPFROM_" TO "_ABSPTO
+48 ;IHS/OIT/SCR 082509 patch 34
SET ABSPGTOT=0
SET ABSPGINS=0
SET ABSPGDUE=0
+49 FOR
SET ABSPSDAT=$ORDER(ABSPTMP(ABSPSDAT))
IF ABSPSDAT=""
QUIT
Begin DoDot:1
+50 IF ABSPTMP(ABSPSDAT)=""
QUIT
+51 SET Y=ABSPSDAT
DO DD^%DT
+52 WRITE !!?10,"RELEASE DATE: "_Y
+53 SET ABSPPHRM=""
+54 FOR
SET ABSPPHRM=$ORDER(ABSPTMP(ABSPSDAT,ABSPPHRM))
IF ABSPPHRM=""
QUIT
Begin DoDot:2
+55 ;IHS/OIT/SCR 082509 patch 34
SET ABSPDTOT=0
SET ABSPDINS=0
SET ABSPDDUE=0
+56 WRITE !!?8,"PHARMACY: "_$PIECE($GET(^ABSP(9002313.56,ABSPPHRM,0)),"^",1)
+57 SET ABSPPRMI=""
+58 FOR
SET ABSPPRMI=$ORDER(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI))
IF ABSPPRMI=""
QUIT
Begin DoDot:3
+59 WRITE !!,"RX #/REFILL: `"_ABSPPRMI_"/"_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),U,1)
+60 SET Y=$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",2)
DO DD^%DT
+61 WRITE !?0,"TRANSACTION DATE: "_Y,?40,"TRANSACTION TYPE: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",4)
+62 WRITE !?5,"DRUG NAME: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",5),?50,"NDC#: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",6)
+63 WRITE !?5,"QTY: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",9),?50,"D/S: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",10)
+64 SET ABSPPROV=$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",7)
+65 WRITE !?5,"PROVIDER NAME: "_$PIECE(^VA(200,ABSPPROV,0),"^",1),?50,"PROVIDER NPI#: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",8)
+66 WRITE !?0,"TOTAL PRICE: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",11),?25,"INSURER PAID: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",12),?53,"AMOUNT DUE: "_$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",13)
+67 ;IHS/OIT/SCR 082509 patch 34 START CHANGES
+68 SET ABSPDTOT=ABSPDTOT+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",11)
+69 SET ABSPDINS=ABSPDINS+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",12)
+70 SET ABSPDDUE=ABSPDDUE+$PIECE(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",13)
End DoDot:3
+71 QUIT
End DoDot:2
+72 WRITE !!,?0,"TOTAL FOR DATE: "_ABSPDTOT,?25,"INS PAID FOR DATE: "_ABSPDINS,?53,"DUE FOR DATE: "_ABSPDDUE
+73 SET ABSPGTOT=ABSPGTOT+ABSPDTOT
+74 SET ABSPGINS=ABSPGINS+ABSPDINS
+75 SET ABSPGDUE=ABSPGDUE+ABSPDDUE
+76 QUIT
End DoDot:1
+77 ;IHS/OIT/SCR 082509 patch 34 END CHANGES
+78 WRITE !!,?0,"GRAND TOTAL: "_ABSPGTOT,?25,"TOTAL INS PAID: "_ABSPGINS,?53,"TOTAL DUE: "_ABSPGDUE
+79 ;IHS/OIT/SCR 1/4/10 patch 36 close the device that was opened
DO ^%ZISC
+80 QUIT
FIND(ABSPSTRT,ABSPEND,ABSPPIEN,ABSPTMP) ; FIND PRESCRIPTIONS FOR THIS PATIENT IN A DATE RANGE
+1 NEW ABSPDONE,ABSPRDT,ABSPPHRM,ABSPRMI,ABSPCTYP,ABSPDAT,ABSPTRXI,ABSPDRGP,ABSPDRGN,ABSPNDC,ABSPPROV
+2 NEW ABSPPNPI,ABSPQTY,ABSPDAYS,ABSPCPAY,ABSPDAYS,ABSPTDAT,ABSPDONE,ABSPCTYN,ABSPTPAT,ABSPTRNS,ABSPRXR,ABSPRXN
+3 NEW ABSPRESP,ABSPPSTN,ABSPNET,RESP
+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
SET ABSPRMI=$ORDER(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI))
IF ABSPRMI'=+ABSPRMI
QUIT
Begin DoDot:2
+10 SET ABSPTRNS=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,3)
+11 IF ABSPTRNS=""
QUIT
+12 ;TRANSACTION PATIENT
SET ABSPTPAT=$PIECE(^ABSPTL(ABSPTRNS,0),U,6)
+13 ;NOT SELECTED PATIENT
IF ABSPTPAT'=ABSPPIEN
QUIT
+14 SET ABSPPHRM=$PIECE(^ABSPTL(ABSPTRNS,1),U,7)
+15 ;IHS/OIT/SCR 010410 patch 36
IF ABSPPHRM=""
SET ABSPPHRM=0
+16 SET ABSPCTYP=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,6)
+17 ;S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5) IHS/OIT/SCR 010420 patch 36
+18 SET ABSPRICE=$PIECE($GET(^ABSPTL(ABSPTRNS,5)),U,5)
+19 ;POINTER TO RESPONSE FILE
SET ABSPRESP=$PIECE(^ABSPTL(ABSPTRNS,0),U,5)
+20 ;POSITION IN CLAIM
SET ABSPPSTN=$PIECE(^ABSPTL(ABSPTRNS,0),U,9)
+21 ;TRANSACTION LAST UPDATE
SET ABSPTDAT=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,2)
+22 ;POINTER TO PRESCRIPTION FILE
SET ABSPTRXI=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,4)
+23 SET ABSPCTYN=""
+24 SET ABSPNET=0
+25 IF ABSPCTYP=1
Begin DoDot:3
+26 SET ABSPCTYN="REJECTED"
+27 SET ABSPPAID=0
+28 SET ABSPCPAY=ABSPRICE
+29 QUIT
End DoDot:3
+30 IF ABSPCTYP=4
Begin DoDot:3
+31 SET ABSPCTYN="E PAYABLE"
+32 IF ABSPRESP=""
QUIT
+33 IF ABSPPSTN=""
QUIT
+34 ;PATIENT PAY AMOUNT
SET ABSPCPAY=$$505^ABSPOS03(ABSPRESP,ABSPPSTN)
+35 ;(#509) Total Amount Paid
SET ABSPPAID=$$509^ABSPOS03(ABSPRESP,ABSPPSTN)
+36 QUIT
End DoDot:3
+37 IF ABSPCTYP=9
Begin DoDot:3
+38 SET ABSPCTYN="PAPER"
+39 SET ABSPPAID=0
+40 SET ABSPCPAY=ABSPRICE
+41 QUIT
End DoDot:3
+42 IF ABSPCTYN=""
QUIT
+43 ;REFILL NUMBER
SET ABSPTRXR=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,5)
+44 ;EXTERNAL PRESCRIPTION NUMBER
SET ABSPTRXN=$PIECE($GET(^PSRX(ABSPTRXI,0)),U,1)
+45 ;POINTER TO DRUG FILE
SET ABSPDRGP=$PIECE($GET(^PSRX(ABSPTRXI,0)),U,6)
+46 ;DRUG NAME
SET ABSPDRGN=$PIECE(^PSDRUG(ABSPDRGP,0),U,1)
+47 ;DRUG NAME
SET ABSPDSYN=$PIECE(^PSDRUG(ABSPDRGP,0),U,1)
+48 ;NDC NUMBER
SET ABSPNDC=$PIECE(^ABSPTL(ABSPTRNS,1),U,2)
+49 ;POINTER TO NEW PERSON FILE (PROVIDER)
SET ABSPPROV=$PIECE(^PSRX(ABSPTRXI,0),U,4)
+50 ;PROVIDER NPI
SET ABSPPNPI=$PIECE($$NPI^XUSNPI("Individual_ID",ABSPPROV),U)
+51 ;PRESCRIPTION QUANTITY
SET ABSPQTY=$PIECE(^PSRX(ABSPTRXI,0),U,7)
+52 ;PRESCRIPTION DAYS SUPPLY
SET ABSPDAYS=$PIECE(^PSRX(ABSPTRXI,0),U,8)
+53 SET ABSPCPAY=$FNUMBER(ABSPCPAY,"",2)
+54 SET ABSPPAID=$FNUMBER(ABSPPAID,"",2)
+55 SET ABSPRICE=$FNUMBER(ABSPRICE,"",2)
+56 SET ABSPTMP(ABSPRDT)=1
+57 SET ABSPTMP(ABSPRDT,ABSPPHRM,ABSPTRXI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPCTYP_"^"_ABSPCTYN_"^"_ABSPDRGN_"^"_ABSPNDC_"^"_ABSPPROV_"^"_ABSPPNPI_"^"_ABSPQTY_"^"_ABSPDAYS_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPCPAY
+58 QUIT
End DoDot:2
+59 QUIT
End DoDot:1
+60 QUIT
GETPAT() ;Prompt the user for which patient they would like to generate an E1 for
+1 NEW ABSPDUZ2,ABSPDONE,Y,DIC
+2 ;set to one when we are done prompting
SET ABSPDONE=0
+3 SET Y=0
+4 SET ABSPDUZ2=+$GET(DUZ(2))
SET DUZ(2)=0
+5 SET DIC=2
SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Generate A patient expense report for which Patient? "
+7 FOR
Begin DoDot:1
+8 DO ^DIC
+9 IF (($GET(DUOUT))!($GET(DTOUT))!(Y>0)!(X=""))
SET ABSPDONE=1
End DoDot:1
IF ABSPDONE
QUIT
+10 KILL DIC
+11 SET DUZ(2)=ABSPDUZ2
+12 QUIT Y
GETPHARM() ;when more than one pharmacy is set up for this site, prompt
+1 ; for which one to use
+2 NEW ABSPHARM,ABSPHLDP,Y,ABSPDONE,ABSPHCNT,DIC
+3 ;initialize beginning variables
SET (ABSPHCNT,ABSPDONE,PHARM,Y)=0
+4 FOR
SET ABSPHARM=$ORDER(^ABSP(9002313.56,PHARM))
IF '+ABSPHARM
QUIT
Begin DoDot:1
+5 SET ABSPHCNT=ABSPHCNT+1
+6 IF ABSPHCNT=1
SET ABSPHLDP=ABSPHARM
End DoDot:1
+7 IF ABSPHCNT=1
QUIT ABSPHLDP
+8 WRITE !!
+9 SET DIC=9002313.56
SET DIC(0)="AEMQZ"
+10 SET DIC("B")=$PIECE($GET(^ABSP(9002313.56,ABSPHLDP,0)),U)
+11 SET DIC("A")="Please specify the pharmacy: "
+12 FOR
Begin DoDot:1
+13 DO ^DIC
+14 IF (($GET(DUOUT))!($GET(DTOUT))!(Y>0))
SET ABSPDONE=1
End DoDot:1
IF ABSPDONE
QUIT
+15 QUIT +Y
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
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 ^%ZISC
+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
ZEND ; CLOSE DEVICE
+1 DO ^%ZISC
+2 QUIT
