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

ABSPOSMF.m

Go to the documentation of this file. 
  1. ABSPOSMF ; IHS/SD/RLT - Medicare Part D Insurer Report ;     [ 01/30/06  09:20 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**16,19,29,37,44**;JAN 30, 2006;Build 38
  1.  Q
  1.  ;
  1.  ;----------------------------------------------------------
  1.  ;IHS/SD/RLT - 10/13/06 - Patch 19
  1.  ; Report not printing to network devices.  Fixed by adding
  1.  ; U IO in tag EN.
  1.  ;----------------------------------------------------------
  1.  ;----------------------------------------------------------
  1.  ;IHS/OIT/SCR - 01/16/09- Patch 29
  1.  ; ADDED EN2 and GETDATA2 for sort by site report
  1.  ;----------------------------------------------------------
  1. EN ;EP
  1.  ;
  1.  W @IOF
  1.  W "Totals by Medicare Part D Insurers",!
  1.  N RANGE S RANGE=$$DTR^ABSPOSU1 Q:RANGE<1
  1.  W !
  1.  N POP D ^%ZIS Q:$G(POP)
  1.  D SETTMP
  1.  D GETDATA($P(RANGE,U),$P(RANGE,U,2))
  1.  U IO        ;IHS/SD/RLT - 10/13/06
  1.  D DISDATA
  1.  D ^%ZISC
  1.  K ^TMP("ABSPOSMF",$J)
  1.  Q
  1.  ;
  1. EN2 ;EP
  1.  ;IHS/OIT/SCR 01/02/09 add to filter by site
  1.  W @IOF
  1.  N ABSPHARM
  1.  W "Totals by Medicare Part D Insurers For site",!
  1.  N RANGE S RANGE=$$DTR^ABSPOSU1 Q:RANGE<1
  1.  S DIC="^ABSP(9002313.56,"
  1.  S DIC(0)="AE"
  1.  S DIC("A")="PHARMACY: "
  1.  S DIC("B")=$P($G(^ABSP(9002313.56,1,0)),"^",1)
  1.  D ^DIC
  1.  Q:Y<0
  1.  S ABSPHARM=$P(Y,"^",1)
  1.  W !
  1.  N POP D ^%ZIS Q:$G(POP)
  1.  D SETTMP
  1.  D GETDATA2($P(RANGE,U),$P(RANGE,U,2),ABSPHARM)
  1.  U IO        ;IHS/SD/RLT - 10/13/06
  1.  D DISDATA
  1.  D ^%ZISC
  1.  K ^TMP("ABSPOSMF",$J)
  1.  Q
  1.  ;
  1. GETDATA(BEGDT,ENDDT) ;
  1.  N RMRELDT,RMIEN,RMNODE0,IEN57,INSIEN,INSNAME
  1.  N PAY,ADJ,PAP,REJ,UNI
  1.  N ABSPCLSD   ;;IHS/OIT/SCR 022010 patch 37
  1.  S RMRELDT=BEGDT-1
  1.  F  S RMRELDT=$O(^ABSPECX("RPT","B",RMRELDT)) Q:'RMRELDT!(RMRELDT>ENDDT)  D
  1.  . S RMIEN=0
  1.  . F  S RMIEN=$O(^ABSPECX("RPT","B",RMRELDT,RMIEN)) Q:'RMIEN  D
  1.  . . S RMNODE0=^ABSPECX("RPT",RMIEN,0)
  1.  . . S IEN57=$P(RMNODE0,U,3)                              ;9002313.57
  1.  . . Q:IEN57=""
  1.  . . S INSIEN=$$GET1^DIQ(9002313.57,IEN57_",",1.06,"I")   ;9999999.18
  1.  . . Q:INSIEN=""                                          ;and 9002313.4
  1.  . . S INSNAME=$$GET1^DIQ(9002313.57,IEN57_",",1.06)
  1.  . . Q:INSNAME=""
  1.  . . S ABSPCLSD=$$GET1^DIQ(9002313.57,IEN57_",",901,"I")  ;IHS/OIT/SCR 022010 patch 37
  1.  . . Q:ABSPCLSD
  1.  . . Q:'$D(^TMP("ABSPOSMF",$J,INSNAME))       ;quit if not already in ^TMP
  1.  . . S PAY=$$GET1^DIQ(9002313.61,RMIEN_",",10006)
  1.  . . S:PAY="" PAY=0
  1.  . . S ADJ=$$GET1^DIQ(9002313.61,RMIEN_",",10007)
  1.  . . S:ADJ="" ADJ=0
  1.  . . S PAP=$$GET1^DIQ(9002313.61,RMIEN_",",10010)
  1.  . . S:PAP="" PAP=0
  1.  . . S REJ=$$GET1^DIQ(9002313.61,RMIEN_",",10013)
  1.  . . S:REJ="" REJ=0
  1.  . . ;
  1.  . . ;Subtotals
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U)+PAY
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,2)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,2)+ADJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,3)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,3)+PAP
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,4)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,4)+REJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,5)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,5)+1
  1.  . . ;
  1.  . . ;Total
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U)+PAY
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,2)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,2)+ADJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,3)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,3)+PAP
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,4)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,4)+REJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,5)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,5)+1
  1.  Q
  1. GETDATA2(BEGDT,ENDDT,ABSPHARM) ;
  1.  ;IHS/OIT/SCR 01/02/08 ADDED TO FILTER RESULTS TO DISPLAY ONLY ONE PHARMACY
  1.  N RMRELDT,RMIEN,RMNODE0,IEN57,INSIEN,INSNAME
  1.  N PAY,ADJ,PAP,REJ,UNI,APSPHRM,ABSPCLSD
  1.  S RMRELDT=BEGDT-1
  1.  F  S RMRELDT=$O(^ABSPECX("RPT","B",RMRELDT)) Q:'RMRELDT!(RMRELDT>ENDDT)  D
  1.  . S RMIEN=0
  1.  . F  S RMIEN=$O(^ABSPECX("RPT","B",RMRELDT,RMIEN)) Q:'RMIEN  D
  1.  . . S RMNODE0=^ABSPECX("RPT",RMIEN,0)
  1.  . . S IEN57=$P(RMNODE0,U,3)                              ;9002313.57
  1.  . . Q:IEN57=""
  1.  . . S INSIEN=$$GET1^DIQ(9002313.57,IEN57_",",1.06,"I")   ;9999999.18
  1.  . . Q:INSIEN=""                                          ;and 9002313.4
  1.  . . S INSNAME=$$GET1^DIQ(9002313.57,IEN57_",",1.06)
  1.  . . Q:INSNAME=""
  1.  . . S ABSPPHRM=$$GET1^DIQ(9002313.57,IEN57_",",1.07,"I")
  1.  . . Q:ABSPPHRM'=ABSPHARM
  1.  . . S ABSPCLSD=$$GET1^DIQ(9002313.57,IEN57_",",901,"I")  ;IHS/OIT/SCR 022010 patch 37
  1.  . . Q:ABSPCLSD
  1.  . . ;QUIT IF THIS RECORD IS NOT FOR THE SELECTED PHARMACY?
  1.  . . Q:'$D(^TMP("ABSPOSMF",$J,INSNAME))       ;quit if not already in ^TMP
  1.  . . S PAY=$$GET1^DIQ(9002313.61,RMIEN_",",10006)
  1.  . . S:PAY="" PAY=0
  1.  . . S ADJ=$$GET1^DIQ(9002313.61,RMIEN_",",10007)
  1.  . . S:ADJ="" ADJ=0
  1.  . . S PAP=$$GET1^DIQ(9002313.61,RMIEN_",",10010)
  1.  . . S:PAP="" PAP=0
  1.  . . S REJ=$$GET1^DIQ(9002313.61,RMIEN_",",10013)
  1.  . . S:REJ="" REJ=0
  1.  . . ;
  1.  . . ;Subtotals
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U)+PAY
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,2)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,2)+ADJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,3)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,3)+PAP
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,4)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,4)+REJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,INSNAME),U,5)=$P($G(^TMP("ABSPOSMF",$J,INSNAME)),U,5)+1
  1.  . . ;
  1.  . . ;Total
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U)+PAY
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,2)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,2)+ADJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,3)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,3)+PAP
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,4)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,4)+REJ
  1.  . . S $P(^TMP("ABSPOSMF",$J,"ZZZZTOTAL"),U,5)=$P($G(^TMP("ABSPOSMF",$J,"ZZZZTOTAL")),U,5)+1
  1.  Q
  1. DISDATA ;
  1.  N DASHES
  1.  S $P(DASHES,"-",80)=""
  1.  N INSNAME,INSREC,PAY,ADJ,PAP,REJ,UNI,CNT
  1.  D HEADING
  1.  I '$D(^TMP("ABSPOSMF",$J)) D  Q
  1.  . W !,"No Medicare D prescriptions found!"
  1.  . D ENDRPT^ABSPOSU5()
  1.  S INSNAME=""
  1.  F  S INSNAME=$O(^TMP("ABSPOSMF",$J,INSNAME)) Q:INSNAME=""  D
  1.  . S INSREC=$G(^TMP("ABSPOSMF",$J,INSNAME))
  1.  . S PAY=$P(INSREC,U)
  1.  . S ADJ=$P(INSREC,U,2)
  1.  . S PAP=$P(INSREC,U,3)
  1.  . S REJ=$P(INSREC,U,4)
  1.  . S CNT=$P(INSREC,U,5)
  1.  . I INSNAME="ZZZZTOTAL" W !,"TOTAL",!
  1.  . E  W !,INSNAME,!
  1.  . W ?20,$J(PAY,10,2)
  1.  . W ?33,$J(ADJ,10,2)
  1.  . W ?46,$J(PAP,10,2)
  1.  . W ?59,$J(REJ,10,2)
  1.  . W ?72,$J(CNT,7)
  1.  . W !,DASHES
  1.  . I $$EOPQ^ABSPOSU8(3,,"D HEADING^"_$T(+0)) S INSNAME="ZZZZZ"
  1.  D ENDRPT^ABSPOSU5()
  1.  W @IOF
  1.  Q
  1. HEADING ;
  1.  W @IOF
  1.  N RPTDATE S RPTDATE=$$NOWEXT^ABSPOSU1
  1.  W "TOTALS BY MEDICARE PART D INSURERS (",$T(+0),")",?60,RPTDATE
  1.  W !,"For "
  1.  N Y S Y=$P(RANGE,U) X ^DD("DD") W Y
  1.  W " through "
  1.  S Y=$P(RANGE,U,2) X ^DD("DD") W Y
  1.  W !!,?21,"PAYABLE",?34,"ADJUSTED",?48,"PAPER",?60,"REJECTED",?72,"RX CNT"
  1.  W !,DASHES
  1.  Q
  1. SETTMP ;Build ^TMP global with all Medicare D insurers in the
  1.  ;ABSP Insurer file.
  1.  ;Set all amounts to zero.  Want to report insurers not
  1.  ;being used.
  1.  K ^TMP("ABSPOSMF",$J)
  1.  N INSIEN,INSNAME,FRMIEN,FRMNAME,MPDFLG
  1.  S INSIEN=0
  1.  F  S INSIEN=$O(^ABSPEI(INSIEN)) Q:'INSIEN  D
  1.  . S INSNAME=$$GET1^DIQ(9002313.4,INSIEN_",",.01)
  1.  . Q:INSNAME=""
  1.  . ;OIT/CAS/RCS Patch 44 07022012 - Comment next 3 lines, no longer looking for format, HEAT # 71654
  1.  . ;S FRMIEN=$$GET1^DIQ(9002313.4,INSIEN_",",100.01,"I")
  1.  . ;Q:FRMIEN=""        ;quit if insurer not tied to a format
  1.  . ;S FRMNAME=$$GET1^DIQ(9002313.4,INSIEN_",",100.01)
  1.  . ;OIT/CAS/RCS Patch 44 07022012 - Comment next line and look at new location in Insurer file for Medicare Part D flag
  1.  . ;S MPDFLG=$$GET1^DIQ(9002313.92,FRMIEN_",",1.2)
  1.  . S MPDFLG=$$GET1^DIQ(9002313.4,INSIEN_",",100.18)
  1.  . Q:MPDFLG'="Y"      ;quit if not a Medicare D format
  1.  . S ^TMP("ABSPOSMF",$J,INSNAME)="0^0^0^0^0"
  1.  Q