Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOSEX

ABSPOSEX.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1. MAIN ;EP
  1.  N ABSPPNAM,ABSPPIEN,ABSPPINF,ABSPPHRM,ABSPRXDT,ABSPARRY,ABSPDOB,ABSPDONE,ABSPTMP,ABSPPHRN,ABSPEND
  1.  N ABSPPDOB,ABSPQUIT,ABSPSDAT,ABSPSDAT,ABSPSTRT,ABSPEND,ABSPPRMI,ABSPFROM,ABSPTO,ABSPPROV
  1.  N ABSPDTOT,ABSPDINS,ABSPDDUE,ABSPGTOT,ABSPGINS,ABSPGDUE ;IHS/OIT/SCR 082509 patch 34
  1.  N IO ;IHS/OIT/SCR 011110 patch 36
  1.  D AUTO^ABSPOSM1()
  1.  S ABSPDONE=0
  1.  S ABSPQUIT=0
  1.  S ABSPPINF=$$GETPAT
  1.  Q:ABSPPINF<1
  1.  S ABSPPIEN=$P(ABSPPINF,U,1)  ;VA(200 patient IEN
  1.  S ABSPPNAM=$P(ABSPPINF,U,2)  ;VA(200 patient name
  1.  S ABSPPDOB=$$DOB^AUPNPAT(ABSPPIEN,"E")
  1.  S ABSPPHRN=$$HRN^AUPNPAT(ABSPPIEN,DUZ(2))
  1.  F  Q:ABSPDONE=1  D
  1.  .S ABSPSTRT=$$BDT()
  1.  .I ABSPSTRT=-1 D
  1.  ..S ABSPQUIT=1
  1.  ..S ABSPDONE=1
  1.  ..Q
  1.  .Q:ABSPQUIT
  1.  .S ABSPEND=$$EDT()
  1.  .I ABSPEND=-1 D
  1.  ..S ABSPQUIT=1
  1.  ..S ABSPDONE=1
  1.  ..Q
  1.  .Q:ABSPQUIT
  1.  .I ABSPSTRT<0 S ABSPDONE=1 Q
  1.  .I ABSPEND<0 S ABSPDONE=1 Q
  1.  .S X2=ABSPSTRT,X1=ABSPEND D ^%DTC
  1.  .I X<0 D EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")
  1.  .I X>=0 S ABSPDONE=1
  1.  .Q
  1.  Q:ABSPQUIT
  1.  D DEVSEL  ;IHS/OIT/SCR 011110 patch 36 NEEDS TO COME BEFORE FIND TO KEEP LOCAL VARIABLES
  1.  D FIND(ABSPSTRT,ABSPEND,ABSPPIEN,.ABSPTMP)
  1.  S ABSPSDAT=""
  1.  S Y=ABSPSTRT D DD^%DT S ABSPFROM=Y
  1.  S Y=ABSPEND D DD^%DT S ABSPTO=Y
  1.  ;D DEVSEL  ;IHS/OIT/SCR 011110 patch 36 start changes
  1.  I $O(ABSPTMP(""))="" D  Q
  1.  .D ^%ZISC
  1.  .W !,"NO TRANSACTIONS FOUND FOR THIS DATE RANGE"
  1.  .Q
  1.  U IO
  1.  W @IOF ;IHS/OIT/SCR 011110 patch 36 end changes
  1.  W !,"PATIENT: "_ABSPPNAM_"   DOB: "_ABSPPDOB_"    HRN: "_ABSPPHRN
  1.  W !?15,"     PHARMACY RELEASE DATES FROM "_ABSPFROM_" TO "_ABSPTO
  1.  S ABSPGTOT=0,ABSPGINS=0,ABSPGDUE=0  ;IHS/OIT/SCR 082509 patch 34
  1.  F  S ABSPSDAT=$O(ABSPTMP(ABSPSDAT)) Q:ABSPSDAT=""  D
  1.  .Q:ABSPTMP(ABSPSDAT)=""
  1.  .S Y=ABSPSDAT D DD^%DT
  1.  .W !!?10,"RELEASE DATE: "_Y
  1.  .S ABSPPHRM=""
  1.  .F  S ABSPPHRM=$O(ABSPTMP(ABSPSDAT,ABSPPHRM)) Q:ABSPPHRM=""  D
  1.  ..S ABSPDTOT=0,ABSPDINS=0,ABSPDDUE=0  ;IHS/OIT/SCR 082509 patch 34
  1.  ..W !!?8,"PHARMACY: "_$P($G(^ABSP(9002313.56,ABSPPHRM,0)),"^",1)
  1.  ..S ABSPPRMI=""
  1.  ..F  S ABSPPRMI=$O(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI)) Q:ABSPPRMI=""  D
  1.  ...W !!,"RX #/REFILL: `"_ABSPPRMI_"/"_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),U,1)
  1.  ...S Y=$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",2) D DD^%DT
  1.  ...W !?0,"TRANSACTION DATE: "_Y,?40,"TRANSACTION TYPE: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",4)
  1.  ...W !?5,"DRUG NAME: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",5),?50,"NDC#: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",6)
  1.  ...W !?5,"QTY: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",9),?50,"D/S: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",10)
  1.  ...S ABSPPROV=$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",7)
  1.  ...W !?5,"PROVIDER NAME: "_$P(^VA(200,ABSPPROV,0),"^",1),?50,"PROVIDER NPI#: "_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",8)
  1.  ...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)
  1.  ...;IHS/OIT/SCR 082509 patch 34 START CHANGES
  1.  ...S ABSPDTOT=ABSPDTOT+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",11)
  1.  ...S ABSPDINS=ABSPDINS+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",12)
  1.  ...S ABSPDDUE=ABSPDDUE+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRMI),"^",13)
  1.  ..Q
  1.  .W !!,?0,"TOTAL FOR DATE: "_ABSPDTOT,?25,"INS PAID FOR DATE: "_ABSPDINS,?53,"DUE FOR DATE: "_ABSPDDUE
  1.  .S ABSPGTOT=ABSPGTOT+ABSPDTOT
  1.  .S ABSPGINS=ABSPGINS+ABSPDINS
  1.  .S ABSPGDUE=ABSPGDUE+ABSPDDUE
  1.  .Q
  1.  ;IHS/OIT/SCR 082509 patch 34 END CHANGES
  1.  W !!,?0,"GRAND TOTAL: "_ABSPGTOT,?25,"TOTAL INS PAID: "_ABSPGINS,?53,"TOTAL DUE: "_ABSPGDUE
  1.  D ^%ZISC  ;IHS/OIT/SCR 1/4/10 patch 36 close the device that was opened
  1.  Q
  1. FIND(ABSPSTRT,ABSPEND,ABSPPIEN,ABSPTMP) ; FIND PRESCRIPTIONS FOR THIS PATIENT IN A DATE RANGE 
  1.  N ABSPDONE,ABSPRDT,ABSPPHRM,ABSPRMI,ABSPCTYP,ABSPDAT,ABSPTRXI,ABSPDRGP,ABSPDRGN,ABSPNDC,ABSPPROV
  1.  N ABSPPNPI,ABSPQTY,ABSPDAYS,ABSPCPAY,ABSPDAYS,ABSPTDAT,ABSPDONE,ABSPCTYN,ABSPTPAT,ABSPTRNS,ABSPRXR,ABSPRXN
  1.  N ABSPRESP,ABSPPSTN,ABSPNET,RESP
  1.  S ABSPRDT=ABSPSTRT-1
  1.  S ABSPDONE=0
  1.  S ABSPRMI=""
  1.  F  S ABSPRDT=$O(^ABSPECX("RPT","B",ABSPRDT)) Q:ABSPRDT=""!ABSPDONE  D
  1.  .I ABSPRDT>ABSPEND S ABSPDONE=1 Q
  1.  .F  S ABSPRMI=$O(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI)) Q:ABSPRMI'=+ABSPRMI  D
  1.  ..S ABSPTRNS=$P(^ABSPECX("RPT",ABSPRMI,0),U,3)
  1.  ..Q:ABSPTRNS=""
  1.  ..S ABSPTPAT=$P(^ABSPTL(ABSPTRNS,0),U,6) ;TRANSACTION PATIENT
  1.  ..Q:ABSPTPAT'=ABSPPIEN  ;NOT SELECTED PATIENT
  1.  ..S ABSPPHRM=$P(^ABSPTL(ABSPTRNS,1),U,7)
  1.  ..S:ABSPPHRM="" ABSPPHRM=0   ;IHS/OIT/SCR 010410 patch 36
  1.  ..S ABSPCTYP=$P(^ABSPECX("RPT",ABSPRMI,0),U,6)
  1.  ..;S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5) IHS/OIT/SCR 010420 patch 36
  1.  ..S ABSPRICE=$P($G(^ABSPTL(ABSPTRNS,5)),U,5)
  1.  ..S ABSPRESP=$P(^ABSPTL(ABSPTRNS,0),U,5)  ;POINTER TO RESPONSE FILE
  1.  ..S ABSPPSTN=$P(^ABSPTL(ABSPTRNS,0),U,9)  ;POSITION IN CLAIM
  1.  ..S ABSPTDAT=$P(^ABSPECX("RPT",ABSPRMI,0),U,2) ;TRANSACTION LAST UPDATE
  1.  ..S ABSPTRXI=$P(^ABSPECX("RPT",ABSPRMI,0),U,4) ;POINTER TO PRESCRIPTION FILE
  1.  ..S ABSPCTYN=""
  1.  ..S ABSPNET=0
  1.  ..I ABSPCTYP=1 D
  1.  ...S ABSPCTYN="REJECTED"
  1.  ...S ABSPPAID=0
  1.  ...S ABSPCPAY=ABSPRICE
  1.  ...Q
  1.  ..I ABSPCTYP=4 D
  1.  ...S ABSPCTYN="E PAYABLE"
  1.  ...Q:ABSPRESP=""
  1.  ...Q:ABSPPSTN=""
  1.  ...S ABSPCPAY=$$505^ABSPOS03(ABSPRESP,ABSPPSTN) ;PATIENT PAY AMOUNT
  1.  ...S ABSPPAID=$$509^ABSPOS03(ABSPRESP,ABSPPSTN) ;(#509) Total Amount Paid
  1.  ...Q
  1.  ..I ABSPCTYP=9 D
  1.  ...S ABSPCTYN="PAPER"
  1.  ...S ABSPPAID=0
  1.  ...S ABSPCPAY=ABSPRICE
  1.  ...Q
  1.  ..Q:ABSPCTYN=""
  1.  ..S ABSPTRXR=$P(^ABSPECX("RPT",ABSPRMI,0),U,5) ;REFILL NUMBER
  1.  ..S ABSPTRXN=$P($G(^PSRX(ABSPTRXI,0)),U,1)  ;EXTERNAL PRESCRIPTION NUMBER
  1.  ..S ABSPDRGP=$P($G(^PSRX(ABSPTRXI,0)),U,6) ;POINTER TO DRUG FILE
  1.  ..S ABSPDRGN=$P(^PSDRUG(ABSPDRGP,0),U,1) ;DRUG NAME
  1.  ..S ABSPDSYN=$P(^PSDRUG(ABSPDRGP,0),U,1) ;DRUG NAME
  1.  ..S ABSPNDC=$P(^ABSPTL(ABSPTRNS,1),U,2)  ;NDC NUMBER
  1.  ..S ABSPPROV=$P(^PSRX(ABSPTRXI,0),U,4) ;POINTER TO NEW PERSON FILE (PROVIDER)
  1.  ..S ABSPPNPI=$P($$NPI^XUSNPI("Individual_ID",ABSPPROV),U)  ;PROVIDER NPI
  1.  ..S ABSPQTY=$P(^PSRX(ABSPTRXI,0),U,7) ;PRESCRIPTION QUANTITY
  1.  ..S ABSPDAYS=$P(^PSRX(ABSPTRXI,0),U,8) ;PRESCRIPTION DAYS SUPPLY
  1.  ..S ABSPCPAY=$FNUMBER(ABSPCPAY,"",2)
  1.  ..S ABSPPAID=$FNUMBER(ABSPPAID,"",2)
  1.  ..S ABSPRICE=$FNUMBER(ABSPRICE,"",2)
  1.  ..S ABSPTMP(ABSPRDT)=1
  1.  ..S ABSPTMP(ABSPRDT,ABSPPHRM,ABSPTRXI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPCTYP_"^"_ABSPCTYN_"^"_ABSPDRGN_"^"_ABSPNDC_"^"_ABSPPROV_"^"_ABSPPNPI_"^"_ABSPQTY_"^"_ABSPDAYS_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPCPAY
  1.  ..Q
  1.  .Q
  1.  Q
  1. GETPAT() ;Prompt the user for which patient they would like to generate an E1 for
  1.  N ABSPDUZ2,ABSPDONE,Y,DIC
  1.  S ABSPDONE=0   ;set to one when we are done prompting
  1.  S Y=0
  1.  S ABSPDUZ2=+$G(DUZ(2)),DUZ(2)=0
  1.  S DIC=2,DIC(0)="AEMQZ"
  1.  S DIC("A")="Generate A patient expense report for which Patient? "
  1.  F  D  Q:ABSPDONE
  1.  . D ^DIC
  1.  . S:(($G(DUOUT))!($G(DTOUT))!(Y>0)!(X="")) ABSPDONE=1
  1.  K DIC
  1.  S DUZ(2)=ABSPDUZ2
  1.  Q Y
  1. GETPHARM() ;when more than one pharmacy is set up for this site, prompt
  1.  ; for which one to use
  1.  N ABSPHARM,ABSPHLDP,Y,ABSPDONE,ABSPHCNT,DIC
  1.  S (ABSPHCNT,ABSPDONE,PHARM,Y)=0   ;initialize beginning variables
  1.  F  S ABSPHARM=$O(^ABSP(9002313.56,PHARM)) Q:'+ABSPHARM  D
  1.  . S ABSPHCNT=ABSPHCNT+1
  1.  . S:ABSPHCNT=1 ABSPHLDP=ABSPHARM
  1.  Q:ABSPHCNT=1 ABSPHLDP
  1.  W !!
  1.  S DIC=9002313.56,DIC(0)="AEMQZ"
  1.  S DIC("B")=$P($G(^ABSP(9002313.56,ABSPHLDP,0)),U)
  1.  S DIC("A")="Please specify the pharmacy: "
  1.  F  D  Q:ABSPDONE
  1.  . D ^DIC
  1.  . S:(($G(DUOUT))!($G(DTOUT))!(Y>0)) ABSPDONE=1
  1.  Q +Y
  1. BDT()  ; ENTER BEGINING DATE
  1.  N ABSPBDT,DIR,X1,X
  1.  W !
  1.  K DIR
  1.  S DIR(0)="DEX"
  1.  S DIR("A")="Enter Beginning Prescription Release Date"
  1.  D ^DIR
  1.  I $D(DIRUT) Q -1
  1.  S ABSPBDT=+Y
  1.  S X1=ABSPBDT D C^%DTC
  1.  Q X
  1. EDT()  ; ENTER END DATE
  1.  N ABSPEDT,DIR,X1,X
  1.  W !
  1.  K DIR
  1.  S DIR(0)="DEX"
  1.  S DIR("A")="Enter Ending Prescription Release Date"
  1.  D ^DIR
  1.  I $D(DIRUT) Q -1
  1.  S ABSPEDT=+Y
  1.  S X1=ABSPEDT D C^%DTC
  1.  Q X
  1. DEVSEL ; SELECT DEVICE
  1.  N ABSPSTOP
  1.  S ABSPSTOP=0
  1.  D ^%ZIS
  1.  I POP D
  1.  .D ^%ZIS
  1.  .Q
  1.  I $D(DUOUT) D
  1.   .D ^%ZISC
  1.   .S ABSPSTOP=1
  1.   .Q
  1.  Q:ABSPSTOP
  1.  I POP D
  1.  .W "DEVICE UNAVAILABLE" G DEVSEL
  1.  Q
  1. ZEND  ; CLOSE DEVICE
  1.  D ^%ZISC
  1.  Q