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

ABMM2EP.m

Go to the documentation of this file. 
  1. ABMM2EP ;IHS/SD/SDR - MU EP List of EPs Report ;
  1.  ;;2.6;IHS 3P BILLING SYSTEM;**11,12**;NOV 12, 2009;Build 187
  1.  ;IHS/SD/SDR - 2.6*12 - HEAT100502 - Print all provider classes; didn't if site added/removed from list.
  1.  ;
  1.  I $P($G(^ABMMUPRM(1,0)),U,2)="" D  Q
  1.  .W !!,"Setup has not been done.  Please do MUP option prior to running any reports",!
  1.  .S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
  1.  ;
  1. EN ;
  1.  D ^XBFMK
  1.  W !!
  1.  S DIR(0)="Y"
  1.  S DIR("A",1)="The output for this report will contain a list of eligible provider classes"
  1.  S DIR("A",2)=""
  1.  S DIR("A",3)="You can also print providers that have an eligible provider class"
  1.  S DIR("A",4)="This could be a lengthy list!"
  1.  S DIR("A",5)=""
  1.  S DIR("A")="Print the list of providers with eligible provider classes as well"
  1.  D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
  1.  S ABMBOTH=Y
  1.  S ABMQ("RC")="COMPUTE^ABMM2EP"
  1.  S ABMQ("RX")="POUT^ABMDRUTL"
  1.  S ABMQ("NS")="ABM"
  1.  S ABMQ("RP")="PRINT^ABMM2EP"
  1.  D ^ABMDRDBQ
  1.  Q
  1. COMPUTE ;
  1.  Q
  1. PRINT ;
  1.  S ABM("PG")=1
  1.  D HDR
  1.  ;start old code abm*2.6*12 HEAT100502
  1.  ;S ABMLAST=$O(^ABMMUPRM(1,2,9999),-1)
  1.  ;S ABMCUTOF=$S(ABMLAST#2=1:(ABMLAST+1)\2,1:ABMLAST\2)
  1.  ;S ABMCNT=0
  1.  ;S ABMCNT2=ABMCUTOF
  1.  ;F  S ABMCNT=$O(^ABMMUPRM(1,2,ABMCNT)) Q:'ABMCNT  D  Q:ABMCNT=ABMCUTOF
  1.  ;.I $Y+5>IOSL D HD Q:(IOST["C")&((+$G(Y)=0)!($D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)))
  1.  ;.S ABMCD=$$GET1^DIQ(7,$P($G(^ABMMUPRM(1,2,ABMCNT,0)),U),9999999.01,"E")
  1.  ;.S ABMPC=$$GET1^DIQ(7,$P($G(^ABMMUPRM(1,2,ABMCNT,0)),U),.01,"E")
  1.  ;.S ABMCD2=$$GET1^DIQ(7,$P($G(^ABMMUPRM(1,2,ABMCNT2,0)),U),9999999.01,"E")
  1.  ;.S ABMPC2=$$GET1^DIQ(7,$P($G(^ABMMUPRM(1,2,ABMCNT2,0)),U),.01,"E")
  1.  ;.S ABMCNT2=ABMCNT2+1
  1.  ;.W !?3,ABMCD,?8,ABMPC,?40,ABMCD2,?45,ABMPC2
  1.  ;end old code start new code HEAT100502
  1.  S ABMI=0,ABMCNT=0
  1.  F  S ABMI=$O(^ABMMUPRM(1,2,ABMI)) Q:'ABMI  D
  1.  .S ABMCNT=ABMCNT+1
  1.  .S ABMCD=$$GET1^DIQ(7,$P($G(^ABMMUPRM(1,2,ABMCNT,0)),U),9999999.01,"E")
  1.  .S ABMPC=$$GET1^DIQ(7,$P($G(^ABMMUPRM(1,2,ABMCNT,0)),U),.01,"E")
  1.  .S ABMTMP(ABMCNT)=ABMCD_U_ABMPC
  1.  S ABMLAST=ABMCNT
  1.  S ABMCUTOF=$S(ABMLAST#2=1:(ABMLAST+1)\2,1:ABMLAST\2)
  1.  S ABMCNT2=ABMCUTOF
  1.  S ABMCNT=0
  1.  F  S ABMCNT=$O(ABMTMP(ABMCNT)) Q:'ABMCNT  D  Q:ABMCNT=ABMCUTOF
  1.  .I $Y+5>IOSL D HD Q:(IOST["C")&((+$G(Y)=0)!($D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)))
  1.  .S ABMCNT2=ABMCNT2+1
  1.  .S ABMCD=$P(ABMTMP(ABMCNT),U)
  1.  .S ABMPC=$P(ABMTMP(ABMCNT),U,2)
  1.  .S ABMCD2=$P($G(ABMTMP(ABMCNT2)),U)
  1.  .S ABMPC2=$P($G(ABMTMP(ABMCNT2)),U,2)
  1.  .W !?3,ABMCD,?8,ABMPC,?40,ABMCD2,?45,ABMPC2
  1.  ;end new code HEAT100502
  1.  ;
  1.  I +$G(ABMBOTH)'=1 Q  ;don't write providers
  1.  S ABM("PG")=ABM("PG")+1
  1.  D HDR2
  1.  K ^XTMP("ABM-EP",$J)
  1.  S ABMNM=""
  1.  S ABMCNT=0
  1.  F  S ABMNM=$O(^VA(200,"B",ABMNM)) Q:$G(ABMNM)=""  D
  1.  .S ABMIEN=0
  1.  .F  S ABMIEN=$O(^VA(200,"B",ABMNM,ABMIEN)) Q:'ABMIEN  D
  1.  ..Q:$$GET1^DIQ(200,ABMIEN,53.5,"I")=""
  1.  ..Q:'$D(^ABMMUPRM(1,2,"B",$$GET1^DIQ(200,ABMIEN,53.5,"I")))  ;not on the provider class list
  1.  ..S ABMCNT=ABMCNT+1
  1.  ..S ^XTMP("ABM-EP",$J,ABMCNT)=$$GET1^DIQ(200,ABMIEN,.01,"E")_U_$$GET1^DIQ(7,$$GET1^DIQ(200,ABMIEN,53.5,"I"),9999999.01,"E")
  1.  S ABMCUTOF=$S(ABMCNT#2=1:(ABMCNT+1)\2,1:ABMCNT\2)
  1.  S ABMCNT=0,ABMCNT2=ABMCUTOF
  1.  F  S ABMCNT=$O(^XTMP("ABM-EP",$J,ABMCNT)) Q:'ABMCNT!(ABMCNT=ABMCUTOF)  D  Q:(IOST["C")&((+$G(Y)=0)!($D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)))
  1.  .I $Y+5>IOSL D HD2 Q:(IOST["C")&((+$G(Y)=0)!($D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT)))
  1.  .S ABMP=$P($G(^XTMP("ABM-EP",$J,ABMCNT)),U)
  1.  .S ABMPC=$P($G(^XTMP("ABM-EP",$J,ABMCNT)),U,2)
  1.  .S ABMP2=$P($G(^XTMP("ABM-EP",$J,ABMCNT2)),U)
  1.  .S ABMPC2=$P($G(^XTMP("ABM-EP",$J,ABMCNT2)),U,2)
  1.  .S ABMCNT2=ABMCNT2+1
  1.  .W !,$E(ABMP,1,33),?35,ABMPC,?40,$E(ABMP2,1,33),?75,ABMPC2
  1.  K ^XTMP("ABM-EP",$J)
  1.  Q
  1.  ;
  1. HD ;
  1.  D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  S ABM("PG")=+$G(ABM("PG"))+1
  1. HDR ;EP
  1.  D EN^ABMVDF("IOF")
  1.  W $C(13)
  1.  D CENTER^ABMUCUTL("               EP Class - List of Eligible Professionals               Page "_ABM("PG"))
  1.  W ! D CENTER^ABMUCUTL("IHS Meaningful Use Patient Volume Report")
  1.  W !
  1.  D NOW^%DTC
  1.  D CENTER^ABMUCUTL("Report Run Date:  "_$$CDT^ABMDUTL(%))
  1.  I ABM("PG")=1 W !!,"PROVIDER CLASSES THAT WILL BE INCLUDED:"
  1.  I ABM("PG")'=1 W !!,"(Cont)"
  1.  W !?3,$$EN^ABMVDF("ULN"),"Code",$$EN^ABMVDF("ULF")
  1.  W ?8,$$EN^ABMVDF("ULN"),"Provider Class",$$EN^ABMVDF("ULF")
  1.  W ?40,$$EN^ABMVDF("ULN"),"Code",$$EN^ABMVDF("ULF")
  1.  W ?45,$$EN^ABMVDF("ULN"),"Provider Class",$$EN^ABMVDF("ULF")
  1.  Q
  1. HD2 ;
  1.  D PAZ^ABMDRUTL Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
  1.  S ABM("PG")=+$G(ABM("PG"))+1
  1. HDR2 ;EP
  1.  D EN^ABMVDF("IOF")
  1.  W $C(13)
  1.  D CENTER^ABMUCUTL("               EP Class - List of Eligible Professionals               Page "_ABM("PG"))
  1.  W ! D CENTER^ABMUCUTL("IHS Meaningful Use Patient Volume Report")
  1.  W !
  1.  D NOW^%DTC
  1.  D CENTER^ABMUCUTL("Report Run Date:  "_$$CDT^ABMDUTL(%))
  1.  I ABM("PG")=1 W !!,"ELIGIBLE PROFESSIONALS"
  1.  I ABM("PG")'=1 W !!,"(Cont)"
  1.  W !,$$EN^ABMVDF("ULN"),"Provider",$$EN^ABMVDF("ULF")
  1.  W ?34,$$EN^ABMVDF("ULN"),"Class",$$EN^ABMVDF("ULF")
  1.  W ?40,$$EN^ABMVDF("ULN"),"Provider",$$EN^ABMVDF("ULF")
  1.  W ?75,$$EN^ABMVDF("ULN"),"Class",$$EN^ABMVDF("ULF")
  1.  Q