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

ABSPOSRY.m

Go to the documentation of this file. 
  1. 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
  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,ABSPREJS,Y,X1,X2,ABSPEND,ABSPSTRT,ABSPDAT,ABSPPRXI,ABSPRJCT
  1.  N ABSPPHMP,ABSPPHMI,ABSPDATP,ABSPDATI,ABSPGRNP,ABSPGRNI,ABSPUSR,ABSPCNT,STARTIME,STOPTIME,ABSPSDAT
  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.  ;D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,.ABSPTMP) IHS/OIT/SCR 083109 patch 34
  1.  S STARTIME=$H
  1.  D FIND(ABSPSTRT,ABSPEND,ABSPPHRM,ABSPUSR,.ABSPREJS)
  1.  S STOPTIME=$H
  1.  S ^TMP("ABSPOSRY-RUNLOG",$J,STARTIME)=ABSPSTRT_"^"_ABSPEND_"^"_($P(STOPTIME,",",2)-$P(STARTIME,",",2))
  1.  I $O(^TMP("ABSPOSRY",$J,""))="" 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(^TMP("ABSPOSRY",$J,ABSPSDAT)) Q:(ABSPSDAT="")!(ABSPQUIT)  D
  1.  .M ABSPTMP(ABSPSDAT)=^TMP("ABSPOSRY",$J,ABSPSDAT)
  1.  .S ABSPDATP=0,ABSPDATI=0 ;IHS/OIT/SCR 082709 patch 34
  1.  .S ABSPPHRM=""
  1.  .S Y=$P(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.  ..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.  .K ABSPTMP(ABSPSDAT)
  1.  .Q:ABSPQUIT
  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,POP
  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,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,ABSPIRME,ABSPPRMI
  1.  N ABSPUSR1,ABSPUSRN,ABSPRESP,ABSPPSTN,ABSPCNT,ABSP1LTP,ABSPRWR,ABSPTRN1,ABSPFND,ABSPCLMI,ABSPCLMS,ABSPIRMI,ABSPTRNS
  1.  S ABSPDONE=0
  1.  S ABSPRDT=ABSPSTRT
  1.  S ABSPEND=ABSPEND_".99999999"
  1.  S ABSPDONE=0
  1.  F  S ABSPRDT=$O(^PSRX("AL",ABSPRDT)) Q:(ABSPRDT="")!(ABSPDONE)!(+ABSPRDT=0)  D
  1.  .I ABSPRDT>ABSPEND S ABSPDONE=1 Q
  1.  .;S ^TMP("ABSPOSRY",$J,$P(ABSPRDT,"."))=""
  1.  .S ABSPPRMI=""
  1.  .F  S ABSPPRMI=$O(^PSRX("AL",ABSPRDT,ABSPPRMI)) Q:ABSPPRMI=""  D
  1.  ..S ABSPFND=0
  1.  ..S ABSPIRMI=ABSPPRMI
  1.  ..S ABSPIRME=ABSPPRMI_".99999999"
  1.  ..F  S ABSPIRMI=$O(^ABSPTL("B",ABSPIRMI)) Q:(ABSPIRMI>ABSPIRME)!(ABSPIRMI="")!(ABSPFND)  D
  1.  ...Q:+$E($P(ABSPIRMI,".",2))>1   ;ONLY PROCESS PRIMARY NOT SECONDARY OR TERTIARY
  1.  ...S ABSPTRNS=""
  1.  ...F  S ABSPTRNS=$O(^ABSPTL("B",ABSPIRMI,ABSPTRNS),-1) Q:(ABSPTRNS="")!(ABSPFND)  D
  1.  ....; WE ONLY WANT PAID CLAIMS HERE
  1.  ....S ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRNS_",","RESULT WITH REVERSAL")
  1.  ....S ABSP1LTP=^ABSPTL(ABSPTRNS,1)
  1.  ....S ABSPUSR1=$P(ABSP1LTP,U,17)
  1.  ....I (ABSPUSR'="ALL"),(ABSPUSR1'=ABSPUSR) Q   ; NOT SELECTED USER
  1.  ....S ABSPPHM1=$P(ABSP1LTP,U,7)    ; SET PHARMACY
  1.  ....I (ABSPPHRM'="ALL")&&(ABSPPHM1'=ABSPPHRM) Q   ; NOT SELECTED PHARMACY
  1.  ....I ABSPPHM1="" Q
  1.  ....I ABSPRWR'="E PAYABLE" 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.  ....S ABSPTRN1=ABSPTRNS
  1.  ....F  S ABSPTRN1=$O(^ABSPTL("B",ABSPIRMI,ABSPTRN1),-1) Q:(ABSPTRN1="")!(ABSPFND)  D
  1.  .....S ABSPRWR=$$GET1^DIQ(9002313.57,ABSPTRN1_",","RESULT WITH REVERSAL")
  1.  .....I (ABSPRWR="E REJECTED")!(ABSPRWR="PAPER") D
  1.  ......S ABSPFND=1
  1.  ......S ABSPTLTP=^ABSPTL(ABSPTRNS,0)
  1.  ......S ABSPRSMI=$P(ABSPTLTP,U,5) ;Response reference
  1.  ......S ABSPCLMI=$P(ABSPTLTP,U,4) ;Claim Reference
  1.  ......Q:(ABSPRSMI="")!(ABSPCLMI="")
  1.  ......S DO=$P(ABSPTLTP,U,9)  ;Position on claim(and response)
  1.  ......;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
  1.  ......Q:DO=""
  1.  ......Q:$D(ABSPCLMS(ABSPIRMI))
  1.  ......S ABSPTINS=$P(ABSP1LTP,U,6)
  1.  ......S ABSPTRXR=$P(ABSP1LTP,U,1)
  1.  ......S ABSPTDAT=$P($P(ABSPTLTP,U,8),".",1)
  1.  ......S ABSPRICE=$P(^ABSPTL(ABSPTRNS,5),U,5)  ;TOTAL PRICE
  1.  ......S ABSPPAID=$$509^ABSPOS03(ABSPRSMI,DO)
  1.  ......S ABSPUSRI=$P(ABSPTLTP,U,17) ;USER LAST UPDATED - IHS/OIT/SCR 082709 patch 34
  1.  ......S ABSPUSRN=""
  1.  ......S:ABSPUSRI>0 ABSPUSRN=$P($G(^VA(200,ABSPUSRI,0)),"^",1)
  1.  ......;IHS/OIT/SCR 082109 START changes patch 34
  1.  ......S ABSPCLMS(ABSPIRMI)=""
  1.  ......;S ^TMP("CPR-RPT",$J,ABSPRDT,ABSPPHM1,ABSPPRMI)=ABSPTRXR_"^"_ABSPTDAT_"^"_ABSPRICE_"^"_ABSPPAID_"^"_ABSPUSRN
  1.  ......S ^TMP("ABSPOSRY",$J,ABSPRDT,ABSPPHM1,ABSPPRMI)=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.  .......;BREAK
  1.  .......K ABSPREJS
  1.  .......D REJTEXT^ABSPOS03(ABSPRSP,ABSPSTN,.ABSPREJS)
  1.  .......F  S ABSPCNT=$O(ABSPREJS(ABSPCNT)) Q:(ABSPCNT="")  D
  1.  ........S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPPRMI,ABSPCNT,"CODE")=$P(ABSPREJS(ABSPCNT),":",1)
  1.  ........S ABSPRJCT(ABSPRDT,ABSPPHM1,ABSPPRMI,ABSPCNT,"REASON")=$P(ABSPREJS(ABSPCNT),":",2)
  1.  ....I 'ABSPFND S ABSPFND=1  ;DONT DO THIS HOLE LOOP AGAIN FOR THE ABSPTRNS
  1.  Q
  1. PRHDR(ABSPSTRT,ABSPEND) ; PRINT HEADER
  1.  N ABSPFEDT,ABSPFBDT
  1.  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.  ;K ^TMP("CPR-RPT",$J)
  1.  K ^TMP("ABSPOSRY",$J)
  1.  D ^%ZISC
  1.  Q