ABMEFOVR.m

ABMEFOVR ; IHS/SD/SDR - Setup 837 Form Override ;   

 ;;2.6;IHS 3P BILLING SYSTEM;**6,8,9,10,21**;NOV 12, 2009;Build 379

 ;IHS/SD/SDR - 2.6*21 - HEAT70826 - Made changes to allow for removal of loop 2310B.

 ;

START ;start

 K DIC,ABMNM

 W !

 D INS Q:'$G(ABMINS)

 D FORM Q:'$G(ABMFORM)

STARTA D VTYP Q:'$G(ABMVTYP)

 D LOOP Q:($G(ABMLOOP)="")

 D SEND Q:$G(ABMSEND)=""

 I ABMLOOP="2310B" D 2310B Q  ;abm*2.6*21 IHS/SD/SDR HEAT70826

 D SEGMENT Q:($G(ABMSEG)="")

 I ABMSEND="N",(ABMSEG="REF") D NOSEND Q

 D ELEMENT Q:($G(ABMELE)="")

 ;

 S ABMNM="FM"_ABMFORM_" "_ABMLOOP_" "_ABMELE_" "_ABMVTYP

 S:ABMVTYP=9999 ABMVTYP=""

 D FILE

 K ABMINS,ABMFORM,ABMLOOP,ABMSEG,ABMELE,ABMANS,ABMDA,ABMEXIST,ABMVTYP,ABMSEND,ABMNM

 Q

INS ;select insurer

 ;S DIC="^ABMNINS(DUZ(2),"  ;abm*2.6*9 NOHEAT

 S DIC="^AUTNINS("  ;abm*2.6*9 NOHEAT

 S DIC(0)="AEMQ"

 D ^DIC Q:+Y<0

 S ABMINS=+Y

 Q

FORM ;select form

 S DIC="^ABMDEXP(",DIC(0)="AEMQ"

 S DIC("S")="I +Y=31!(+Y=32)!(+Y=33)"

 D ^DIC K DIC

 Q:+Y<0

 S ABMFORM=+Y

 Q

VTYP ;select visit type

 S DIC="^ABMDVTYP("

 S DIC(0)="AEMQ"

 S DIC("A")="Enter visit type, or leave blank for all. "

 D ^DIC

 I X="" D

 .S Y=9999

 .W "ALL"

 Q:+Y<0

 S ABMVTYP=+Y

 Q

LOOP ;select loop

 S DIR(0)="S^"_$P($T(LOOPS),";;",2)

 S DIR("A")="Select Loop"

 D ^DIR K DIR

 Q:'+Y

 S ABMLOOP=Y(0)

 Q

SEND ;select send/don't send

 S DIR(0)="S^S:Send;N:Don't Send"

 S DIR("A")="Select"

 D ^DIR K DIR

 S ABMSEND=Y

 Q

 ;start new abm*2.6*21 IHS/SD/SDR HEAT70826

2310B ;EP

 I ABMSEND="N" D ASKLOOP Q

 Q:'$D(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,"2310B","N"))

 ;if it gets here that means that they had said Don't send but are changing it to send

 ;existing entry should just be removed

 S DA(1)=ABMINS

 S DA=$O(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,"2310B","00",0,"N",0))

 S DIK="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 D ^DIK

 Q

ASKLOOP ;

 S DIR(0)="Y"

 S DIR("A")="Remove WHOLE loop"

 S DIR("B")="N"

 D ^DIR K DIR

 S ABMSKIPL=Y

 I ABMSKIPL="N" Q

 S ABMQFLG=1

 I '$D(^ABMNINS(DUZ(2),ABMINS)) D  Q:+Y<0

 .D ^XBFMK

 .S X="`"_ABMINS

 .S DIC="^ABMNINS(DUZ(2),"

 .S DIC(0)="LX"

 .D ^DIC

 D ^XBFMK

 S ABMNM="FM"_ABMFORM_" "_ABMLOOP_" DON'T SEND"

 S:ABMVTYP=9999 ABMVTYP=""

 S DA(1)=ABMINS

 S DIC="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 S DIC("P")=$P(^DD(9002274.09,2.5,0),U,2)

 S X=ABMNM

 S DIC(0)="LXE" D ^DIC

 Q:+Y<0

 S DA=+Y

 S ABMDA=DA

 S DIE=DIC

 S ABMANS=1

 I $P(Y,U,3)'=1 D

 .S DIR(0)="S^1:ADD/EDIT;2:DELETE"

 .S DIR("A")="Add/Edit or Delete Entry?"

 .S DIR("B")="ADD/EDIT"

 .D ^DIR K DIR

 .Q:'Y  S ABMANS=Y

 I ABMANS=1 D

 .S DR=".02///"_ABMFORM_";.03///"_ABMLOOP_";.04////00;.05////0;.06///"_ABMVTYP_";.08///"_ABMSEND

 S:ABMANS=2 DR=".01///@"

 D ^DIE

 I ABMANS=2 D

 .W !,"Entry Deleted.",!

 .D EOP^ABMDUTL(1)

 Q

 ;end new abm*2.6*21 IHS/SD/SDR HEAT70826

SEGMENT ;select segment

 S DIR(0)="S^"_$P($T(@ABMLOOP),";;",2)

 S DIR("A")="Select Segment"

 D ^DIR K DIR

 Q:'+Y

 S ABMSEG=Y(0)

 Q

ELEMENT ;select element

 D ^XBFMK

 S DIR(0)="SO^"_$P($T(@ABMSEG),";;",2)

 S DIR("A")="Select Element"

 D ^DIR K DIR

 Q:'+Y

 S ABMELE=Y(0)

 I ABMSEND="S"&(+$O(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,ABMLOOP,ABMSEG,ABMELE,"N",0))'=0) D

 .D ^XBFMK

 .S DA(1)=ABMINS

 .S DA=$O(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,ABMLOOP,ABMSEG,ABMELE,"N",0))

 .S DIK="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 .D ^DIK

 Q

FILE ;

 S ABMEXIST=$G(^ABMNINS(DUZ(2),ABMINS,2.5,"A837",ABMFORM,ABMLOOP,ABMSEG,ABMELE,+ABMVTYP)) D

 .Q:ABMEXIST=""

 .W !!,"Current Value: ",ABMEXIST

 .W !,"Visit Type: ",$S(ABMVTYP="":"ALL",1:ABMVTYP)

 D ^XBFMK

 S DA(1)=ABMINS

 S DIC="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 S DIC("P")=$P(^DD(9002274.09,2.5,0),U,2)

 S X=ABMNM

 S DIC(0)="LXE" D ^DIC

 Q:+Y<0

 S DA=+Y

 S ABMDA=DA

 S DIE=DIC

 S ABMANS=1

 I $P(Y,U,3)'=1 D

 .S DIR(0)="S^1:ADD/EDIT;2:DELETE"

 .S DIR("A")="Add/Edit or Delete Entry?"

 .S DIR("B")="ADD/EDIT"

 .D ^DIR K DIR

 .Q:'Y  S ABMANS=Y

 I ABMANS=1 D

 .S DR=".02///"_ABMFORM_";.03///"_ABMLOOP_";.04///"_ABMSEG_";.05///"_ABMELE_";.06///"_ABMVTYP_";.08///"_ABMSEND

 .I ABMSEND="S" S DR=DR_";.07//"

 S:ABMANS=2 DR=".01///@"

 D ^DIE

 I ABMANS=2 D

 .W !,"Entry Deleted.",!

 .D EOP^ABMDUTL(1)

 I ABMNM["ISA"!(ABMNM["GS")!(ABMNM["NM")!(ABMNM["REF") D

 .K DIR

 .S DIR(0)="Y"

 .S DIR("A")="EDIT ANOTHER SEGMENT?"

 .S DIR("B")="N"

 .D ^DIR

 .K DIR

 .I Y=1 K ABMLOOP,ABMSEG,ABMELE,ABMVTYP G STARTA

 Q

NOSEND ;

 S ABMNM="FM"_ABMFORM_" "_ABMLOOP_" "_ABMSEG_" DON'T SEND"

 S:ABMVTYP=9999 ABMVTYP=""

 S ABMELE=""

 D ^XBFMK

 S DA(1)=ABMINS

 S DIC="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 S DIC("P")=$P(^DD(9002274.09,2.5,0),U,2)

 S X=ABMNM

 S DIC(0)="LXE" D ^DIC

 Q:+Y<0

 S DA=+Y

 S ABMDA=DA

 S DIE=DIC

 S DR=".02///"_ABMFORM_";.03///"_ABMLOOP_";.04///"_ABMSEG_";.05///"_ABMELE_";.06///"_ABMVTYP_";.08///"_ABMSEND

 D ^DIE

 Q

 ;

LOOPS ;;1:HEADER;2:1000A;3:1000B;4:2010AA;5:2010BB;6:2000B;7:2310B

 ;abm*2.6*21 IHS/SD/SDR HEAT70826 added loop 2310B

 ;

HEADER ;;1:ISA;2:GS

1000A ;;1:NM1

1000B ;;1:NM1

2010AA ;;1:NM1;2:REF

2010BB ;;1:NM1

2000B ;;1:SBR

 ;

ISA ;;1:ISA02;2:ISA03;3:ISA04;4:ISA05;5:ISA06;6:ISA07;7:ISA08;8:ISA14;9:ISA15

 ;;1:ISA02;2:ISA03;3:ISA04;4:ISA05;5:ISA06;6:ISA07;7:ISA08;8:ISA15  ;old line abm*2.6*10 HEAT74624

 ;;1:ISA03;2:ISA04;3:ISA05;4:ISA06;5:ISA07;6:ISA08;7:ISA15  ;old line ABM*2.6*8

GS ;;1:GS02;2:GS03

NM1 ;;1:NM103;2:NM108;3:NM109

REF ;;1:REF01;2:REF02

SBR ;;1:SBR09

ABMEFOVR  ; IHS/SD/SDR - Setup 837 Form Override ;   

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**6,8,9,10,21**;NOV 12, 2009;Build 379

 +2       ;IHS/SD/SDR - 2.6*21 - HEAT70826 - Made changes to allow for removal of loop 2310B.

 +3       ;

START     ;start

 +1        KILL DIC,ABMNM

 +2        WRITE !

 +3        DO INS

           IF '$GET(ABMINS)

               QUIT 

 +4        DO FORM

           IF '$GET(ABMFORM)

               QUIT 

STARTA     DO VTYP

           IF '$GET(ABMVTYP)

               QUIT 

 +1        DO LOOP

           IF ($GET(ABMLOOP)="")

               QUIT 

 +2        DO SEND

           IF $GET(ABMSEND)=""

               QUIT 

 +3       ;abm*2.6*21 IHS/SD/SDR HEAT70826

           IF ABMLOOP="2310B"

               DO 2310B

               QUIT 

 +4        DO SEGMENT

           IF ($GET(ABMSEG)="")

               QUIT 

 +5        IF ABMSEND="N"

               IF (ABMSEG="REF")

                   DO NOSEND

                   QUIT 

 +6        DO ELEMENT

           IF ($GET(ABMELE)="")

               QUIT 

 +7       ;

 +8        SET ABMNM="FM"_ABMFORM_" "_ABMLOOP_" "_ABMELE_" "_ABMVTYP

 +9        IF ABMVTYP=9999

               SET ABMVTYP=""

 +10       DO FILE

 +11       KILL ABMINS,ABMFORM,ABMLOOP,ABMSEG,ABMELE,ABMANS,ABMDA,ABMEXIST,ABMVTYP,ABMSEND,ABMNM

 +12       QUIT 

INS       ;select insurer

 +1       ;S DIC="^ABMNINS(DUZ(2),"  ;abm*2.6*9 NOHEAT

 +2       ;abm*2.6*9 NOHEAT

           SET DIC="^AUTNINS("

 +3        SET DIC(0)="AEMQ"

 +4        DO ^DIC

           IF +Y<0

               QUIT 

 +5        SET ABMINS=+Y

 +6        QUIT 

FORM      ;select form

 +1        SET DIC="^ABMDEXP("

           SET DIC(0)="AEMQ"

 +2        SET DIC("S")="I +Y=31!(+Y=32)!(+Y=33)"

 +3        DO ^DIC

           KILL DIC

 +4        IF +Y<0

               QUIT 

 +5        SET ABMFORM=+Y

 +6        QUIT 

VTYP      ;select visit type

 +1        SET DIC="^ABMDVTYP("

 +2        SET DIC(0)="AEMQ"

 +3        SET DIC("A")="Enter visit type, or leave blank for all. "

 +4        DO ^DIC

 +5        IF X=""

               Begin DoDot:1

 +6                SET Y=9999

 +7                WRITE "ALL"

               End DoDot:1

 +8        IF +Y<0

               QUIT 

 +9        SET ABMVTYP=+Y

 +10       QUIT 

LOOP      ;select loop

 +1        SET DIR(0)="S^"_$PIECE($TEXT(LOOPS),";;",2)

 +2        SET DIR("A")="Select Loop"

 +3        DO ^DIR

           KILL DIR

 +4        IF '+Y

               QUIT 

 +5        SET ABMLOOP=Y(0)

 +6        QUIT 

SEND      ;select send/don't send

 +1        SET DIR(0)="S^S:Send;N:Don't Send"

 +2        SET DIR("A")="Select"

 +3        DO ^DIR

           KILL DIR

 +4        SET ABMSEND=Y

 +5        QUIT 

 +6       ;start new abm*2.6*21 IHS/SD/SDR HEAT70826

2310B     ;EP

 +1        IF ABMSEND="N"

               DO ASKLOOP

               QUIT 

 +2        IF '$DATA(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,"2310B","N"))

               QUIT 

 +3       ;if it gets here that means that they had said Don't send but are changing it to send

 +4       ;existing entry should just be removed

 +5        SET DA(1)=ABMINS

 +6        SET DA=$ORDER(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,"2310B","00",0,"N",0))

 +7        SET DIK="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 +8        DO ^DIK

 +9        QUIT 

ASKLOOP   ;

 +1        SET DIR(0)="Y"

 +2        SET DIR("A")="Remove WHOLE loop"

 +3        SET DIR("B")="N"

 +4        DO ^DIR

           KILL DIR

 +5        SET ABMSKIPL=Y

 +6        IF ABMSKIPL="N"

               QUIT 

 +7        SET ABMQFLG=1

 +8        IF '$DATA(^ABMNINS(DUZ(2),ABMINS))

               Begin DoDot:1

 +9                DO ^XBFMK

 +10               SET X="`"_ABMINS

 +11               SET DIC="^ABMNINS(DUZ(2),"

 +12               SET DIC(0)="LX"

 +13               DO ^DIC

               End DoDot:1

               IF +Y<0

                   QUIT 

 +14       DO ^XBFMK

 +15       SET ABMNM="FM"_ABMFORM_" "_ABMLOOP_" DON'T SEND"

 +16       IF ABMVTYP=9999

               SET ABMVTYP=""

 +17       SET DA(1)=ABMINS

 +18       SET DIC="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 +19       SET DIC("P")=$PIECE(^DD(9002274.09,2.5,0),U,2)

 +20       SET X=ABMNM

 +21       SET DIC(0)="LXE"

           DO ^DIC

 +22       IF +Y<0

               QUIT 

 +23       SET DA=+Y

 +24       SET ABMDA=DA

 +25       SET DIE=DIC

 +26       SET ABMANS=1

 +27       IF $PIECE(Y,U,3)'=1

               Begin DoDot:1

 +28               SET DIR(0)="S^1:ADD/EDIT;2:DELETE"

 +29               SET DIR("A")="Add/Edit or Delete Entry?"

 +30               SET DIR("B")="ADD/EDIT"

 +31               DO ^DIR

                   KILL DIR

 +32               IF 'Y

                       QUIT 

                   SET ABMANS=Y

               End DoDot:1

 +33       IF ABMANS=1

               Begin DoDot:1

 +34               SET DR=".02///"_ABMFORM_";.03///"_ABMLOOP_";.04////00;.05////0;.06///"_ABMVTYP_";.08///"_ABMSEND

               End DoDot:1

 +35       IF ABMANS=2

               SET DR=".01///@"

 +36       DO ^DIE

 +37       IF ABMANS=2

               Begin DoDot:1

 +38               WRITE !,"Entry Deleted.",!

 +39               DO EOP^ABMDUTL(1)

               End DoDot:1

 +40       QUIT 

 +41      ;end new abm*2.6*21 IHS/SD/SDR HEAT70826

SEGMENT   ;select segment

 +1        SET DIR(0)="S^"_$PIECE($TEXT(@ABMLOOP),";;",2)

 +2        SET DIR("A")="Select Segment"

 +3        DO ^DIR

           KILL DIR

 +4        IF '+Y

               QUIT 

 +5        SET ABMSEG=Y(0)

 +6        QUIT 

ELEMENT   ;select element

 +1        DO ^XBFMK

 +2        SET DIR(0)="SO^"_$PIECE($TEXT(@ABMSEG),";;",2)

 +3        SET DIR("A")="Select Element"

 +4        DO ^DIR

           KILL DIR

 +5        IF '+Y

               QUIT 

 +6        SET ABMELE=Y(0)

 +7        IF ABMSEND="S"&(+$ORDER(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,ABMLOOP,ABMSEG,ABMELE,"N",0))'=0)

               Begin DoDot:1

 +8                DO ^XBFMK

 +9                SET DA(1)=ABMINS

 +10               SET DA=$ORDER(^ABMNINS(DUZ(2),ABMINS,2.5,"ASEND",ABMFORM,ABMLOOP,ABMSEG,ABMELE,"N",0))

 +11               SET DIK="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 +12               DO ^DIK

               End DoDot:1

 +13       QUIT 

FILE      ;

 +1        SET ABMEXIST=$GET(^ABMNINS(DUZ(2),ABMINS,2.5,"A837",ABMFORM,ABMLOOP,ABMSEG,ABMELE,+ABMVTYP))

           Begin DoDot:1

 +2            IF ABMEXIST=""

                   QUIT 

 +3            WRITE !!,"Current Value: ",ABMEXIST

 +4            WRITE !,"Visit Type: ",$SELECT(ABMVTYP="":"ALL",1:ABMVTYP)

           End DoDot:1

 +5        DO ^XBFMK

 +6        SET DA(1)=ABMINS

 +7        SET DIC="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 +8        SET DIC("P")=$PIECE(^DD(9002274.09,2.5,0),U,2)

 +9        SET X=ABMNM

 +10       SET DIC(0)="LXE"

           DO ^DIC

 +11       IF +Y<0

               QUIT 

 +12       SET DA=+Y

 +13       SET ABMDA=DA

 +14       SET DIE=DIC

 +15       SET ABMANS=1

 +16       IF $PIECE(Y,U,3)'=1

               Begin DoDot:1

 +17               SET DIR(0)="S^1:ADD/EDIT;2:DELETE"

 +18               SET DIR("A")="Add/Edit or Delete Entry?"

 +19               SET DIR("B")="ADD/EDIT"

 +20               DO ^DIR

                   KILL DIR

 +21               IF 'Y

                       QUIT 

                   SET ABMANS=Y

               End DoDot:1

 +22       IF ABMANS=1

               Begin DoDot:1

 +23               SET DR=".02///"_ABMFORM_";.03///"_ABMLOOP_";.04///"_ABMSEG_";.05///"_ABMELE_";.06///"_ABMVTYP_";.08///"_ABMSEND

 +24               IF ABMSEND="S"

                       SET DR=DR_";.07//"

               End DoDot:1

 +25       IF ABMANS=2

               SET DR=".01///@"

 +26       DO ^DIE

 +27       IF ABMANS=2

               Begin DoDot:1

 +28               WRITE !,"Entry Deleted.",!

 +29               DO EOP^ABMDUTL(1)

               End DoDot:1

 +30       IF ABMNM["ISA"!(ABMNM["GS")!(ABMNM["NM")!(ABMNM["REF")

               Begin DoDot:1

 +31               KILL DIR

 +32               SET DIR(0)="Y"

 +33               SET DIR("A")="EDIT ANOTHER SEGMENT?"

 +34               SET DIR("B")="N"

 +35               DO ^DIR

 +36               KILL DIR

 +37               IF Y=1

                       KILL ABMLOOP,ABMSEG,ABMELE,ABMVTYP

                       GOTO STARTA

               End DoDot:1

 +38       QUIT 

NOSEND    ;

 +1        SET ABMNM="FM"_ABMFORM_" "_ABMLOOP_" "_ABMSEG_" DON'T SEND"

 +2        IF ABMVTYP=9999

               SET ABMVTYP=""

 +3        SET ABMELE=""

 +4        DO ^XBFMK

 +5        SET DA(1)=ABMINS

 +6        SET DIC="^ABMNINS(DUZ(2),"_DA(1)_",2.5,"

 +7        SET DIC("P")=$PIECE(^DD(9002274.09,2.5,0),U,2)

 +8        SET X=ABMNM

 +9        SET DIC(0)="LXE"

           DO ^DIC

 +10       IF +Y<0

               QUIT 

 +11       SET DA=+Y

 +12       SET ABMDA=DA

 +13       SET DIE=DIC

 +14       SET DR=".02///"_ABMFORM_";.03///"_ABMLOOP_";.04///"_ABMSEG_";.05///"_ABMELE_";.06///"_ABMVTYP_";.08///"_ABMSEND

 +15       DO ^DIE

 +16       QUIT 

 +17      ;

LOOPS     ;;1:HEADER;2:1000A;3:1000B;4:2010AA;5:2010BB;6:2000B;7:2310B

 +1       ;abm*2.6*21 IHS/SD/SDR HEAT70826 added loop 2310B

 +2       ;

HEADER    ;;1:ISA;2:GS

1000A     ;;1:NM1

1000B     ;;1:NM1

2010AA    ;;1:NM1;2:REF

2010BB    ;;1:NM1

2000B     ;;1:SBR

 +1       ;

ISA       ;;1:ISA02;2:ISA03;3:ISA04;4:ISA05;5:ISA06;6:ISA07;7:ISA08;8:ISA14;9:ISA15

 +1       ;;1:ISA02;2:ISA03;3:ISA04;4:ISA05;5:ISA06;6:ISA07;7:ISA08;8:ISA15  ;old line abm*2.6*10 HEAT74624

 +2       ;;1:ISA03;2:ISA04;3:ISA05;4:ISA06;5:ISA07;6:ISA08;7:ISA15  ;old line ABM*2.6*8

GS        ;;1:GS02;2:GS03

NM1       ;;1:NM103;2:NM108;3:NM109

REF       ;;1:REF01;2:REF02

SBR       ;;1:SBR09