ABMMUMUP ;IHS/SD/SDR - MU Report Parameters ;
;;2.6;IHS 3P BILLING SYSTEM;**7,8**;NOV 12, 2009
;
W !!
I $P($G(^ABMMUPRM(1,0)),U,2)'="" D Q
.W !!,"Setup has already been done. Contact OIT if changes need to be made",!
.S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
D ^XBFMK
S DIR(0)="Y"
S DIR("A",1)="You are setting up the Report Parameters. Once completed, you will not be able to edit."
S DIR("A")="Continue"
S DIR("B")="N"
D ^DIR K DIR
Q:Y<1
D ^XBFMK
S DIR(0)="Y"
S DIR("A")="Do you wish to designate a Facility as an FQHC or RHC"
D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
S ABMANS=+Y
EN ;
I ABMANS=1 D
.D GETFACS
.W !!
.S ABMCNT=0,ABMDIR=""
.F S ABMCNT=$O(ABMFLIST(ABMCNT)) Q:'ABMCNT D
..W !?2,ABMCNT_".",?6,$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
..S:ABMDIR'="" ABMDIR=ABMDIR_";"_ABMCNT_":"_$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
..S:ABMDIR="" ABMDIR=ABMCNT_":"_$$GET1^DIQ(9999999.06,$G(ABMFLIST(ABMCNT)),.01,"E")
.S ABMCNT=$O(ABMFLIST(99999),-1) ;get last entry#
.S (ABMCNT,ABMTOT)=ABMCNT+1
.W !!
.K ABMFANS,ABMF
.F D Q:+$G(Y)<0!$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) ;they didn't answer
..D ^XBFMK
..S DIR(0)="SAO^"_$G(ABMDIR)
..S DIR("A")="Select one or more facilities to designate as an FQHC or RHC: "
..D ^DIR K DIR
..Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
..Q:+$G(Y)<0
..S ABMFANS=Y
..S ABMF($G(ABMFLIST(ABMFANS)))=""
..D ^XBFMK
..S DIR(0)="Y"
..S DIR("A")="Is this FQHC led by a PA? "
..D ^DIR K DIR
..Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
..S ABMF($G(ABMFLIST(ABMFANS)))=Y
..I ABMFANS=(ABMCNT+1) D
...S ABMCNT=0
...F S ABMCNT=$O(ABMF(ABMCNT)) Q:'ABMCNT S ABMF($G(ABMFLIST(ABMFANS)))=ABMFANS2
I $D(ABMF) D
.W !!!,"The following have been identified by you as FQHC/RHC facilities"
.S ABMCNT=0
.F S ABMCNT=$O(ABMF(ABMCNT)) Q:'ABMCNT D
..W !?2,$$GET1^DIQ(9999999.06,ABMCNT,.01,"E")
..W:+$G(ABMF(ABMCNT))=0 " (FQHC)"
..W:+$G(ABMF(ABMCNT))=1 " (FQHC led by PA)"
.D ^XBFMK
.S DIR(0)="Y"
.S DIR("A",1)=""
.S DIR("A",2)="By answering YES the entries below will be added and the list may not be edited without contacting OIT"
.S DIR("A",3)=""
.S DIR("A")="Are you sure"
.D ^DIR K DIR
.Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
.S ABMFANS=Y
S DIE="^ABMMUPRM("
S DR=".02////Y"
S DA=1
D ^DIE
;
S ABMLOC=0
F S ABMLOC=$O(ABMF(ABMLOC)) Q:'ABMLOC D ADDENTRY(ABMLOC)
K ABMDIR,ABMFLIST
W !!,"Some states consider Optometrists, Podiatrists, etc., as Physicians."
W !!,"The next prompt will allow the identification of these provider classes as"
W !,"EP types to generate volume reports."
W !!,"Please note: Defaults have been provided so there are already entries in this"
W !,"file that don't need to be entered again."
D ^XBFMK
S DIR(0)="Y"
S DIR("A")="Are there additional EP types for your state"
D ^DIR K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
Q:Y=0
F D Q:+$G(Y)<0!$D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)
.D ^XBFMK
.S DA(1)=1
.S DIC="^ABMMUPRM("_DA(1)_",2,"
.S DIC("P")=$P(^DD(9002274.55,2,0),U,2)
.S DIC(0)="AELMQ"
.D ^DIC
Q
ADDENTRY(ABMLOC) ;
D ^XBFMK
S DA(1)=1
S DIC="^ABMMUPRM("_DA(1)_",1,"
S DIC("P")=$P(^DD(9002274.55,1,0),U,2)
S DIC(0)="LMQ"
S X="`"_ABMLOC
D ^DIC
;start old code abm*2.6*8
;S DIE=DIC
;S DA(1)=1
;S DA=ABMLOC
;end old code start new code
S ABMIEN=+Y
D ^XBFMK
S DA(1)=1
S DA=ABMIEN
S DIE="^ABMMUPRM("_DA(1)_",1,"
;end new code
S DR=".02////"_$G(ABMF(ABMLOC))
D ^DIE
Q
GETFACS ;EP
K ABMPSFLG,ABMFLIST
S ABMPAR=0
S ABMCNT=1
F S ABMPAR=$O(^BAR(90052.05,ABMPAR)) Q:+ABMPAR=0 D Q:($G(ABMPSFLG)=1)
.I $D(^BAR(90052.05,ABMPAR,DUZ(2))) D
..; Use A/R parent/sat is yes, but DUZ(2) is not the parent for this
..; visit location
..Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,3)'=ABMPAR
..Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,6)>DT
..Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,7)&($P(^(0),U,7)<DT)
..S ABMPSFLG=1
S ABMFLIST(ABMCNT)=ABMPAR
S ABMCNT=+$G(ABMCNT)+1
S ABML=0
F S ABML=$O(^BAR(90052.05,ABMPAR,ABML)) Q:'ABML D
.Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,6)>DT
.Q:$P($G(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,7)&($P(^(0),U,7)<DT)
.Q:ABMPAR=ABML
.S ABMFLIST(ABMCNT)=ABML
.S ABMCNT=+$G(ABMCNT)+1
Q
ABMMUMUP ;IHS/SD/SDR - MU Report Parameters ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**7,8**;NOV 12, 2009
+2 ;
+3 WRITE !!
+4 IF $PIECE($GET(^ABMMUPRM(1,0)),U,2)'=""
Begin DoDot:1
+5 WRITE !!,"Setup has already been done. Contact OIT if changes need to be made",!
+6 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+7 DO ^XBFMK
+8 SET DIR(0)="Y"
+9 SET DIR("A",1)="You are setting up the Report Parameters. Once completed, you will not be able to edit."
+10 SET DIR("A")="Continue"
+11 SET DIR("B")="N"
+12 DO ^DIR
KILL DIR
+13 IF Y<1
QUIT
+14 DO ^XBFMK
+15 SET DIR(0)="Y"
+16 SET DIR("A")="Do you wish to designate a Facility as an FQHC or RHC"
+17 DO ^DIR
KILL DIR
+18 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+19 SET ABMANS=+Y
EN ;
+1 IF ABMANS=1
Begin DoDot:1
+2 DO GETFACS
+3 WRITE !!
+4 SET ABMCNT=0
SET ABMDIR=""
+5 FOR
SET ABMCNT=$ORDER(ABMFLIST(ABMCNT))
IF 'ABMCNT
QUIT
Begin DoDot:2
+6 WRITE !?2,ABMCNT_".",?6,$$GET1^DIQ(9999999.06,$GET(ABMFLIST(ABMCNT)),.01,"E")
+7 IF ABMDIR'=""
SET ABMDIR=ABMDIR_";"_ABMCNT_":"_$$GET1^DIQ(9999999.06,$GET(ABMFLIST(ABMCNT)),.01,"E")
+8 IF ABMDIR=""
SET ABMDIR=ABMCNT_":"_$$GET1^DIQ(9999999.06,$GET(ABMFLIST(ABMCNT)),.01,"E")
End DoDot:2
+9 ;get last entry#
SET ABMCNT=$ORDER(ABMFLIST(99999),-1)
+10 SET (ABMCNT,ABMTOT)=ABMCNT+1
+11 WRITE !!
+12 KILL ABMFANS,ABMF
+13 ;they didn't answer
FOR
Begin DoDot:2
+14 DO ^XBFMK
+15 SET DIR(0)="SAO^"_$GET(ABMDIR)
+16 SET DIR("A")="Select one or more facilities to designate as an FQHC or RHC: "
+17 DO ^DIR
KILL DIR
+18 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+19 IF +$GET(Y)<0
QUIT
+20 SET ABMFANS=Y
+21 SET ABMF($GET(ABMFLIST(ABMFANS)))=""
+22 DO ^XBFMK
+23 SET DIR(0)="Y"
+24 SET DIR("A")="Is this FQHC led by a PA? "
+25 DO ^DIR
KILL DIR
+26 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+27 SET ABMF($GET(ABMFLIST(ABMFANS)))=Y
+28 IF ABMFANS=(ABMCNT+1)
Begin DoDot:3
+29 SET ABMCNT=0
+30 FOR
SET ABMCNT=$ORDER(ABMF(ABMCNT))
IF 'ABMCNT
QUIT
SET ABMF($GET(ABMFLIST(ABMFANS)))=ABMFANS2
End DoDot:3
End DoDot:2
IF +$GET(Y)<0!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
End DoDot:1
+31 IF $DATA(ABMF)
Begin DoDot:1
+32 WRITE !!!,"The following have been identified by you as FQHC/RHC facilities"
+33 SET ABMCNT=0
+34 FOR
SET ABMCNT=$ORDER(ABMF(ABMCNT))
IF 'ABMCNT
QUIT
Begin DoDot:2
+35 WRITE !?2,$$GET1^DIQ(9999999.06,ABMCNT,.01,"E")
+36 IF +$GET(ABMF(ABMCNT))=0
WRITE " (FQHC)"
+37 IF +$GET(ABMF(ABMCNT))=1
WRITE " (FQHC led by PA)"
End DoDot:2
+38 DO ^XBFMK
+39 SET DIR(0)="Y"
+40 SET DIR("A",1)=""
+41 SET DIR("A",2)="By answering YES the entries below will be added and the list may not be edited without contacting OIT"
+42 SET DIR("A",3)=""
+43 SET DIR("A")="Are you sure"
+44 DO ^DIR
KILL DIR
+45 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+46 SET ABMFANS=Y
End DoDot:1
+47 SET DIE="^ABMMUPRM("
+48 SET DR=".02////Y"
+49 SET DA=1
+50 DO ^DIE
+51 ;
+52 SET ABMLOC=0
+53 FOR
SET ABMLOC=$ORDER(ABMF(ABMLOC))
IF 'ABMLOC
QUIT
DO ADDENTRY(ABMLOC)
+54 KILL ABMDIR,ABMFLIST
+55 WRITE !!,"Some states consider Optometrists, Podiatrists, etc., as Physicians."
+56 WRITE !!,"The next prompt will allow the identification of these provider classes as"
+57 WRITE !,"EP types to generate volume reports."
+58 WRITE !!,"Please note: Defaults have been provided so there are already entries in this"
+59 WRITE !,"file that don't need to be entered again."
+60 DO ^XBFMK
+61 SET DIR(0)="Y"
+62 SET DIR("A")="Are there additional EP types for your state"
+63 DO ^DIR
KILL DIR
+64 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+65 IF Y=0
QUIT
+66 FOR
Begin DoDot:1
+67 DO ^XBFMK
+68 SET DA(1)=1
+69 SET DIC="^ABMMUPRM("_DA(1)_",2,"
+70 SET DIC("P")=$PIECE(^DD(9002274.55,2,0),U,2)
+71 SET DIC(0)="AELMQ"
+72 DO ^DIC
End DoDot:1
IF +$GET(Y)<0!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT
+73 QUIT
ADDENTRY(ABMLOC) ;
+1 DO ^XBFMK
+2 SET DA(1)=1
+3 SET DIC="^ABMMUPRM("_DA(1)_",1,"
+4 SET DIC("P")=$PIECE(^DD(9002274.55,1,0),U,2)
+5 SET DIC(0)="LMQ"
+6 SET X="`"_ABMLOC
+7 DO ^DIC
+8 ;start old code abm*2.6*8
+9 ;S DIE=DIC
+10 ;S DA(1)=1
+11 ;S DA=ABMLOC
+12 ;end old code start new code
+13 SET ABMIEN=+Y
+14 DO ^XBFMK
+15 SET DA(1)=1
+16 SET DA=ABMIEN
+17 SET DIE="^ABMMUPRM("_DA(1)_",1,"
+18 ;end new code
+19 SET DR=".02////"_$GET(ABMF(ABMLOC))
+20 DO ^DIE
+21 QUIT
GETFACS ;EP
+1 KILL ABMPSFLG,ABMFLIST
+2 SET ABMPAR=0
+3 SET ABMCNT=1
+4 FOR
SET ABMPAR=$ORDER(^BAR(90052.05,ABMPAR))
IF +ABMPAR=0
QUIT
Begin DoDot:1
+5 IF $DATA(^BAR(90052.05,ABMPAR,DUZ(2)))
Begin DoDot:2
+6 ; Use A/R parent/sat is yes, but DUZ(2) is not the parent for this
+7 ; visit location
+8 IF $PIECE($GET(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,3)'=ABMPAR
QUIT
+9 IF $PIECE($GET(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,6)>DT
QUIT
+10 IF $PIECE($GET(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,7)&($PIECE(^(0),U,7)<DT)
QUIT
+11 SET ABMPSFLG=1
End DoDot:2
End DoDot:1
IF ($GET(ABMPSFLG)=1)
QUIT
+12 SET ABMFLIST(ABMCNT)=ABMPAR
+13 SET ABMCNT=+$GET(ABMCNT)+1
+14 SET ABML=0
+15 FOR
SET ABML=$ORDER(^BAR(90052.05,ABMPAR,ABML))
IF 'ABML
QUIT
Begin DoDot:1
+16 IF $PIECE($GET(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,6)>DT
QUIT
+17 IF $PIECE($GET(^BAR(90052.05,ABMPAR,DUZ(2),0)),U,7)&($PIECE(^(0),U,7)<DT)
QUIT
+18 IF ABMPAR=ABML
QUIT
+19 SET ABMFLIST(ABMCNT)=ABML
+20 SET ABMCNT=+$GET(ABMCNT)+1
End DoDot:1
+21 QUIT
