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

ABSPOSR9.m

Go to the documentation of this file. 
  1. ABSPOSR9  ;IHS/OIT/SCR - COLLECTION PRODUCTIVITY REPORT
  1.  ;;1.0;PHARMACY POINT OF SALE;**38,40**;JUN 21, 2001;Build 38
  1.  ; OPTION: ABSP RPT COLLECTION PRODUCT
  1.  ; DISPLAYS COST AMOUNT RECOVERED FOR TRANSACTIONS THAT WERE REJECTED AT ONE TIME AND HAVE
  1.  ; BECOME PAYABLE FOR A RANGE OF RELEASE DATES LIKE THE WRR, BUT ALSO INCLUDES
  1.  ; REJECT CODES FROM THE MOST RECENT REJECTED TRANSACTION AND IDENTIFIES FIELDS AND MODIFIED
  1.  ; VALUES THAT WERE USED TO MAKE THE CLAIM PAYABLE
  1. EN ;  EP
  1.  N ABSPQUIT,ABSPDONE,ABSPQUIT,ABSPPHRM,ABSPTMP,ABSPREJS,Y,X1,X2,ABSPEND,ABSPSTRT,ABSPDAT,ABSPPRXI
  1.  N ABSPPHMP,ABSPPHMI,ABSPDATP,ABSPDATI,ABSPGRNP,ABSPGRNI,ABSPUSR,ABSPCNT,STARTIME,STOPTIME
  1.  ;D AUTO^ABSPOSM1()
  1.  S ABSPDONE=0
  1.  S ABSPQUIT=0
  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.  S ABSPPHRM=$$CLNC()
  1.  Q:ABSPPHRM=-1
  1.  S ABSPUSR=$$USER()
  1.  D ^XBCLS
  1.  S ABSPTMP=""
  1.  ;D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,.ABSPTMP) IHS/OIT/SCR 083109 patch 34
  1.  S STARTIME=$H
  1.  D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,.ABSPTMP,.ABSPREJS)
  1.  S STOPTIME=$H
  1.  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
  1.  S Y=ABSPSTRT D DD^%DT S ABSPFROM=Y
  1.  S Y=ABSPEND D DD^%DT S ABSPTO=Y
  1.  I $O(ABSPTMP(""))="" D
  1.  .W !,"      ****NO RECORDS FOUND FOR DATE RANGE***",!!
  1.  .N DIR
  1.  .S DIR(0)="Y"
  1.  .S DIR("A")="PRINT ANYWAY"
  1.  .D ^DIR
  1.  .I Y'=1 S ABSPQUIT=1
  1.  .Q
  1.  Q:ABSPQUIT
  1.  D DEVSEL
  1.  D PRHDR(ABSPSTRT,ABSPEND)
  1.  S ABSPSDAT=""
  1.  S ABSPGRNP=0,ABSPGRNI=0 ;IHS/OIT/SCR 082709 patch 34
  1.  F  S ABSPSDAT=$O(ABSPTMP(ABSPSDAT)) Q:(ABSPSDAT="")!(ABSPQUIT)  D
  1.  .S ABSPDATP=0,ABSPDATI=0 ;IHS/OIT/SCR 082709 patch 34
  1.  .S ABSPPHRM=""
  1.  .S Y=ABSPSDAT
  1.  .D DD^%DT
  1.  .;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  .S ABSPQUIT=$$WRITE^ABSPOSUU("!!?10,""RELEASED DATE: ""_Y")
  1.  .Q:ABSPQUIT
  1.  .F  S ABSPPHRM=$O(ABSPTMP(ABSPSDAT,ABSPPHRM)) Q:(ABSPPHRM="")!(ABSPQUIT)  D
  1.  ..S ABSPPHMP=0,ABSPPHMI=0
  1.  ..;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen, use paging
  1.  ..S ABSPQUIT=$$WRITE^ABSPOSUU("!?15,""PHARMACY: ""_$P($G(^ABSP(9002313.56,ABSPPHRM,0)),U,1)")
  1.  ..Q:ABSPQUIT
  1.  ..I ABSPUSR="ALL" S ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ALL""")
  1.  ..Q:ABSPQUIT
  1.  ..I ABSPUSR'="ALL" S ABSPQUIT=$$WRITE^ABSPOSUU("!,?19,""USER: ""_$P($G(^VA(200,ABSPUSR,0)),U,1)")
  1.  ..Q:ABSPQUIT
  1.  ..S ABSPPRXI=""
  1.  ..F  S ABSPPRXI=$O(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI)) Q:(ABSPPRXI="")!(ABSPQUIT)  D
  1.  ...;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  ...S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""RX #/REFILL: `""_ABSPPRXI_""/""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,1)")
  1.  ...Q:ABSPQUIT
  1.  ...S Y=$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",2) D DD^%DT
  1.  ...;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  ...S ABSPQUIT=$$WRITE^ABSPOSUU("!?5,""TRANSACTION DATE: ""_Y,?40,""RECOVERED BY: ""_$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),U,5)")
  1.  ...Q:ABSPQUIT
  1.  ...;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
  1.  ...;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  ...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)")
  1.  ...Q:ABSPQUIT
  1.  ...S ABSPPHMP=ABSPPHMP+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",3)
  1.  ...S ABSPPHMI=ABSPPHMI+$P(ABSPTMP(ABSPSDAT,ABSPPHRM,ABSPPRXI),"^",4)
  1.  ...;PRINT OUT REJECTION REASONS FOR THE REJECTION BEFORE THE PAID TXN
  1.  ...S ABSPCNT=0
  1.  ...F  S ABSPCNT=$O(ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT)) Q:(ABSPCNT="")!(ABSPQUIT)  D
  1.  ....;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  ....S ABSPQUIT=$$WRITE^ABSPOSUU("!?15,ABSPCNT_"". REJECTION CODE: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""CODE"")")
  1.  ....Q:ABSPQUIT
  1.  ....S ABSPQUIT=$$WRITE^ABSPOSUU("?20,""REASON: ""_ABSPRJCT(ABSPSDAT,ABSPPHRM,ABSPPRXI,ABSPCNT,""REASON"")")
  1.  ....Q:ABSPQUIT
  1.  ...Q:ABSPQUIT
  1.  ...;PRINT OUT FIELDS AND VALUES OF ENTRIES IN ABSP NCPDP OVERRIDE FILE FOR THIS TXN
  1.  ...;W !!
  1.  ...;S ABSPCNT=0
  1.  ...;F  S ABSPCNT=$O(ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT)) Q:ABSPCNT=""  D
  1.  ...;.W !,?5,"MOST RECENT OVERIDE FIELD: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"FIELD")
  1.  ...;.W !,?15,"CHANGED TO: "_ABSPORID(ABSPSDAT,ABSPPRM,ATSPPRXI,ABSPCNT,"NEW VALUE")
  1.  ..Q:ABSPQUIT
  1.  ..;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  ..S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""PHARMACY TOTAL ""_$FNUMBER(ABSPPHMP,"","",2),?40,""INSURER PAID: ""_$FNUMBER(ABSPPHMI,"","",2)")
  1.  ..Q:ABSPQUIT
  1.  ..S ABSPDATP=ABSPDATP+ABSPPHMP
  1.  ..S ABSPDATI=ABSPDATI+ABSPPHMI
  1.  .;W !!,"TOTAL PRICE FOR DATE: "_ABSPPHMP,?25,"TOTAL PAID BY INSURER FOR DATE: "_ABSPPHMI
  1.  .Q:ABSPQUIT
  1.  .;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  .S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""DATE TOTAL: ""_$FNUMBER(ABSPPHMP,"","",2),?40,""TOTAL PAID BY INSURER FOR DATE: ""_$FNUMBER(ABSPPHMI,"","",2)")
  1.  .Q:ABSPQUIT
  1.  .S ABSPGRNP=ABSPGRNP+ABSPDATP
  1.  .S ABSPGRNI=ABSPGRNI+ABSPDATI
  1.  I ABSPQUIT D ZEND Q
  1.  ;W !!,"GRAND TOTAL PRICE: "_ABSPGRNP,?25,"GRAND TOTAL PAID BY INSURER :"_ABSPGRNI
  1.  ;IHS/OIT/CNI/RAN 05042010 patch 38 - When printing to screen, use paging
  1.  S ABSPQUIT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: ""_$FNUMBER(ABSPGRNP,"","",2),?40,""GRAND TOTAL INSURER PAID: ""_$FNUMBER(ABSPGRNI,"","",2)")
  1.  D ZEND   ;IHS/OIT/SCR 1/4/09 patch 36 close the printer device
  1.  Q
  1. CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES
  1.  N DIC,X,Y,ABSPPHRM
  1.  S DIC="^ABSP(9002313.56,"
  1.  S DIC(0)="AEMQVZ"
  1.  S DIC("A")="Please Select a Pharmacy or leave blank for ALL:  "
  1.  D ^DIC K DIC
  1.  I X["^" Q -1
  1.  I Y=-1 S ABSPPHRM="ALL"
  1.  I Y>-1 S ABSPPHRM=$P(Y,"^",1)
  1.  Q ABSPPHRM
  1. USER() ; PICK WHICH OR ALL NEW PESRSON
  1.  ;IHS/OIT/SCR 083109 patch 34
  1.  N DIC,X,Y,ABSPUSER
  1.  S DIC="^VA(200,"
  1.  S DIC(0)="AEMQVZ"
  1.  S DIC("A")="Please Select a User or leave blank for ALL:  "
  1.  D ^DIC K DIC
  1.  I X["^" Q -1
  1.  I Y=-1 S ABSPUSER="ALL"
  1.  I Y>-1 S ABSPUSER=$P(Y,"^",1)
  1.  Q ABSPUSER
  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 ZEND
  1.   .S ABSPSTOP=1
  1.   .Q
  1.  Q:ABSPSTOP
  1.  I POP D
  1.  .W "DEVICE UNAVAILABLE" G DEVSEL
  1.  Q
  1. 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.  N ABSPDONE,ABSPRDT,ABSPTDAT,ABSPTRXN,ABSPPHM1,APSPTRXI,ABSPRICE,ABSPFND,ABSPRXI,ABSPTRXR,ABSPRXN,ABSPTRXR
  1.  N ABSPUSR1,ABSPUSRN,ABSPRESP,ABSPPSTN,ABSPCNT
  1.  ;S ABSPUSR1=0
  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 ABSPJ=1:1 S ABSPRMI=$O(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI)) Q:ABSPRMI'=+ABSPRMI  D
  1.  ..I $P(^ABSPECX("RPT",ABSPRMI,0),U,6)'=4 Q   ; NOT A PAYABLE CLAIM
  1.  ..S ABSPTRNS=$P(^ABSPECX("RPT",ABSPRMI,0),U,3)
  1.  ..S ABSPPHM1=""
  1.  ..I ABSPPHRM'="ALL" D
  1.  ...I $P(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPHRM Q   ; NOT SELECTED PHARMACY
  1.  ...S ABSPPHM1=ABSPPHRM
  1.  ...Q
  1.  ..I ABSPPHRM="ALL" S ABSPPHM1=$P(^ABSPTL(ABSPTRNS,1),U,7)    ; SET PHARMACY
  1.  ..I ABSPPHM1="" Q
  1.  ..S ABSPUSR1=-1
  1.  ..I ABSPUSR'="ALL" D
  1.  ...I $P(^ABSPTL(ABSPTRNS,0),U,17)'=ABSPUSR Q  ; NOT SELECTED USER
  1.  ...S ABSPUSR1=ABSPUSR
  1.  ...Q
  1.  ..I ABSPUSR="ALL" S ABSPUSR1=$P(^ABSPTL(ABSPTRNS,1),U,17)    ; SET USER
  1.  ..I ABSPUSR1=-1 Q
  1.  ..;IHS/OIT/SCR 083109 patch 32 END
  1.  ..S ABSPTRXI=$P(^ABSPTL(ABSPTRNS,1),U,11)
  1.  ..S ABSPTRXR=$P(^ABSPTL(ABSPTRNS,1),U,1)
  1.  ..I ABSPTRXI=""!(ABSPTRXR="") Q
  1.  ..;NOW WE HAVE A PAYABLE CLAIM...BUT IT ONLY BELONGS ON THIS REPORT IF IT HAS BEEN REJECTED BEFORE
  1.  ..;SO....WE HAVE TO  LOOK AT THE LOG OF TRANSACTIONS FOR THIS PRESCRIPTION BEFORE THE ONE
  1.  ..;WE HAVE IN OUR HANDS...IF THAT ONE WAS REJECTED, PUT THIS INFO ON THE REPORT
  1.  ..;Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,""),-1)  ;FOUND IN ABSPOS57 AND ABSPOSBB
  1.  ..S ABSPFND=0
  1.  ..S ABSPTRN1=""
  1.  ..F  S ABSPTRN1=$O(^ABSPTL("NON-FILEMAN","RXIRXR",ABSPTRXI,ABSPTRXR,ABSPTRN1),-1) Q:ABSPTRN1=""!(ABSPFND=1)  D
  1.  ...S ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRN1_",","RESULT WITH REVERSAL")
  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.  ...;I ABSPRWR="E REJECTED" D
  1.  ...I (ABSPRWR="E REJECTED")!(ABSPRWR="PAPER") D
  1.  ....S ABSPPAID=0
  1.  ....I (ABSPRESP'="")&(ABSPPSTN'="") S ABSPPAID=$$509^ABSPOS03(ABSPRESP,ABSPPSTN) ;(#509) Total Amount Paid
  1.  ....S ABSPFND=1
  1.  ....S ABSPRXI=$P(^ABSPECX("RPT",ABSPRMI,0),U,4) ;POINTER TO PRESCRIPTION FILE
  1.  ....S ABSPRXN=$P($G(^PSRX(ABSPRXI,0)),U,1)  ;PRESCRIPTION NUMBER
  1.  ....S ABSPTDAT=$P(^ABSPECX("RPT",ABSPRMI,0),U,2) ;TRANSACTION LAST UPDATE
  1.  ....S ABSPTRXR=$P(^ABSPECX("RPT",ABSPRMI,0),U,5) ;REFIL NUMBER
  1.  ....S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5)  ;TOTAL PRICE
  1.  ....S ABSPUSRI=$P(^ABSPTL(ABSPTRNS,0),U,17) ;USER LAST UPDATED - IHS/OIT/SCR 082709 patch 34
  1.  ....;S ABSPUSRI=$P(^ABSPTL(ABSPTRNS,0),U,10)
  1.  ....S ABSPUSRN=""
  1.  ....;S ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
  1.  ....S:ABSPUSRI>0 ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
  1.  ....S ABSPTMP(ABSPRDT,ABSPPHM1,ABSPRXI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPUSRN
  1.  ....;This populates ABSPREJS(n) with code:text format of each rejection for this position in this response
  1.  ....S ABSPCNT=0
  1.  ....S ABSPRSP=$P(^ABSPTL(ABSPTRN1,0),U,5)  ;POINTER TO RESPONSE FILE for REJECTED transaction
  1.  ....S ABSPSTN=$P(^ABSPTL(ABSPTRN1,0),U,9)  ;POSITION IN CLAIM for REJECTED transaction
  1.  ....I $G(ABSPRSP)'="" D
  1.  .....;FOR EACH REJECTION CODE AND REASON associated to the REJECTED TRANSACTION, add it to an array
  1.  .....D REJTEXT^ABSPOS03(ABSPRSP,ABSPSTN,.ABSPREJS)
  1.  .....F  S ABSPCNT=$O(ABSPREJS(ABSPCNT)) Q:(ABSPCNT=""!ABSPQUIT)  D
  1.  ......S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPRXI,ABSPCNT,"CODE")=$P(ABSPREJS(ABSPCNT),":",1)
  1.  ......S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPRXI,ABSPCNT,"REASON")=$P(ABSPREJS(ABSPCNT),":",2)
  1.  Q
  1. PRHDR(ABSPSTRT,ABSPEND) ; PRINT HEADER
  1.  N ABSPFEDT,ABSPFBDT
  1.  U IO W @IOF
  1.  S Y=ABSPSTRT
  1.  D DD^%DT
  1.  S ABSPFBDT=Y
  1.  S Y=ABSPEND
  1.  D DD^%DT
  1.  S ABSPFEDT=Y
  1.  W !,?19,"Pharmacy Point of Sale Collection Productivity Report"
  1.  W !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT
  1.  Q
  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. ZEND   ;Close the device that was opened
  1.  D ^%ZISC
  1.  Q