ABMDSPLT.m

ABMDSPLT ; IHS/ASDST/DMJ - SPLIT CLAIM IN TWO ;     

 ;;2.6;IHS Third Party Billing;**1,3,9,10,21**;NOV 12, 2009;Build 379

 ;

 ; IHS/SD/SDR - v2.5 p12 - UFMS

 ;   Added check to see if user is logged in before splitting

 ;   claims allowed

 ; IHS/SD/SDR - abm*2.6*1 - HEAT4480 - Added ARE YOU SURE prior to split

 ; IHS/SD/SDR - abm*2.6*3 - HEAT11948 - fix for <UNDEF>START+3^AUPNPAT

 ;IHS/SD/SDR - 2.6*21 - HEAT190661 - If user types '^' at section prompt they will be exited out of option without split.

 ;  Also rearranged code so claim wouldn't get created until sections to be copied/moved were selected.

 ;

 ; *********************************************************************

 ;

START ;START

 W !

 ;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup

 I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)="" D  Q

 .W !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!

 .S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR

 ;end new code

 I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1 D  Q:+$G(ABMUOPNS)=0

 .S ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)

 .I +$G(ABMUOPNS)=0 D  Q

 ..W !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!

 ..S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR

 D ^ABMDEDIC

 Q:'$G(ABMP("CDFN"))

 S DIC="^ABMDCLM(DUZ(2),",DIC(0)="L"

 S X=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)

 ;start new code abm*2.6*1 HEAT4480

 W !!

 S DIR(0)="Y",DIR("A")="You are about to split a claim.  Are you sure?"

 S DIR("B")="NO"

 D ^DIR K DIR

 G:Y=0 START

 ;S X=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)  ;abm*2.6*3 HEAT11948  ;abm*2.6*21 IHS/SD/SDR 190661

 ;end new code HEAT4480

 ;start old abm*2.6*21 IHS/SD/SDR HEAT190661

 ;S DINUM=$$NXNM^ABMDUTL

 ;I DINUM="" D  Q

 ;.W !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"

 ;.S DIR(0)="E" D ^DIR K DIR

 ;K DD,DO D FILE^DICN Q:+Y<0  S ABMC2=+Y

 ;M ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN"))

 ;S DIE="^ABMDCLM(DUZ(2),"

 ;S DA=ABMC2

 ;S DR=".1////"_DT_";.04///E"

 ;S DR=DR_";.17////"_DT

 ;S DR=DR_";.022////S"  ;abm*2.6*10 ICD10 008

 ;D ^DIE

 ;;start new code ;abm*2.6*10 ICD10 008

 ;S DIE="^ABMDCLM(DUZ(2),"

 ;S DA=ABMP("CDFN")

 ;S DR=".022////O"  ;abm*2.6*10 ICD10 008

 ;D ^DIE

 ;end new code 008

 ;end old abm*2.6*21 IHS/SD/SDR HEAT190661

MLI ;MOVE LINE ITEMS

 S ABMSTRG=""

 S DIR(0)="SO^8A:MEDICAL;8B:SURGICAL;8C:REVENUE CODE;8D:RX;8E:LAB;8F:RADIOLOGY;8G:ANESTHESIA;8H:HCPCS;8I:INPATIENT DENTAL;8J:CHARGE MASTER;8Z:ALL"

 S DIR("A")="Move Which Section(s)? "

 F  D  Q:'Y

 .D ^DIR

 .Q:'Y

 .S:ABMSTRG'[Y ABMSTRG=ABMSTRG_Y_"^"

 .W !!,"Selected: ",$TR(ABMSTRG,"^"," ")

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

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) W !!,"Split will not occur..." H 1 Q

 S X=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)

 S DINUM=$$NXNM^ABMDUTL

 I DINUM="" D  Q

 .W !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"

 .S DIR(0)="E" D ^DIR K DIR

 K DD,DO D FILE^DICN Q:+Y<0  S ABMC2=+Y

 M ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN"))

 S DIE="^ABMDCLM(DUZ(2),"

 S DA=ABMC2

 S DR=".1////"_DT_";.04///E"

 S DR=DR_";.17////"_DT

 S DR=DR_";.022////S"

 D ^DIE

 S DIE="^ABMDCLM(DUZ(2),"

 S DA=ABMP("CDFN")

 S DR=".022////O"

 D ^DIE

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

 K DIR

 W !

 I ABMSTRG'["8Z" D

 .S DIR(0)="Y",DIR("A")="Delete sections from original claim after move"

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

 .D ^DIR K DIR

 .S:Y=1 ABMDLT=1

 D DEL

 S DIK="^ABMDCLM(DUZ(2),"

 F DA=ABMC2,ABMP("CDFN") D

 .K ^ABMDCLM(DUZ(2),DA,"ASRC")

 .D IX1^DIK

 W !!,"Claim # ",ABMC2," created.",!

 K ABMSTRG,ABMDLT,ABMC2,ABMPG,ABMSEC

 S DIR(0)="E" D ^DIR K DIR

 Q

DEL ;DELETE SECTIONS

 K ^ABMDCLM(DUZ(2),ABMC2,13)

 F I=1:1:10 D

 .S ABMPG=$P("8A^8B^8C^8D^8E^8F^8G^8H^8I^8J","^",I)

 .S ABMSEC=$P("27^21^25^23^37^35^39^43^33^45","^",I)

 .I $G(ABMDLT),ABMSTRG[ABMPG K ^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMSEC)

 .Q:ABMSTRG["8Z"

 .I '(ABMSTRG[ABMPG) K ^ABMDCLM(DUZ(2),ABMC2,ABMSEC)

 Q

ABMDSPLT  ; IHS/ASDST/DMJ - SPLIT CLAIM IN TWO ;     

 +1       ;;2.6;IHS Third Party Billing;**1,3,9,10,21**;NOV 12, 2009;Build 379

 +2       ;

 +3       ; IHS/SD/SDR - v2.5 p12 - UFMS

 +4       ;   Added check to see if user is logged in before splitting

 +5       ;   claims allowed

 +6       ; IHS/SD/SDR - abm*2.6*1 - HEAT4480 - Added ARE YOU SURE prior to split

 +7       ; IHS/SD/SDR - abm*2.6*3 - HEAT11948 - fix for <UNDEF>START+3^AUPNPAT

 +8       ;IHS/SD/SDR - 2.6*21 - HEAT190661 - If user types '^' at section prompt they will be exited out of option without split.

 +9       ;  Also rearranged code so claim wouldn't get created until sections to be copied/moved were selected.

 +10      ;

 +11      ; *********************************************************************

 +12      ;

START     ;START

 +1        WRITE !

 +2       ;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup

 +3        IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=""

               Begin DoDot:1

 +4                WRITE !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!

 +5                SET DIR(0)="E"

                   SET DIR("A")="Enter RETURN to Continue"

                   DO ^DIR

                   KILL DIR

               End DoDot:1

               QUIT 

 +6       ;end new code

 +7        IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1

               Begin DoDot:1

 +8                SET ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)

 +9                IF +$GET(ABMUOPNS)=0

                       Begin DoDot:2

 +10                       WRITE !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!

 +11                       SET DIR(0)="E"

                           SET DIR("A")="Enter RETURN to Continue"

                           DO ^DIR

                           KILL DIR

                       End DoDot:2

                       QUIT 

               End DoDot:1

               IF +$GET(ABMUOPNS)=0

                   QUIT 

 +12       DO ^ABMDEDIC

 +13       IF '$GET(ABMP("CDFN"))

               QUIT 

 +14       SET DIC="^ABMDCLM(DUZ(2),"

           SET DIC(0)="L"

 +15       SET X=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)

 +16      ;start new code abm*2.6*1 HEAT4480

 +17       WRITE !!

 +18       SET DIR(0)="Y"

           SET DIR("A")="You are about to split a claim.  Are you sure?"

 +19       SET DIR("B")="NO"

 +20       DO ^DIR

           KILL DIR

 +21       IF Y=0

               GOTO START

 +22      ;S X=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)  ;abm*2.6*3 HEAT11948  ;abm*2.6*21 IHS/SD/SDR 190661

 +23      ;end new code HEAT4480

 +24      ;start old abm*2.6*21 IHS/SD/SDR HEAT190661

 +25      ;S DINUM=$$NXNM^ABMDUTL

 +26      ;I DINUM="" D  Q

 +27      ;.W !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"

 +28      ;.S DIR(0)="E" D ^DIR K DIR

 +29      ;K DD,DO D FILE^DICN Q:+Y<0  S ABMC2=+Y

 +30      ;M ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN"))

 +31      ;S DIE="^ABMDCLM(DUZ(2),"

 +32      ;S DA=ABMC2

 +33      ;S DR=".1////"_DT_";.04///E"

 +34      ;S DR=DR_";.17////"_DT

 +35      ;S DR=DR_";.022////S"  ;abm*2.6*10 ICD10 008

 +36      ;D ^DIE

 +37      ;;start new code ;abm*2.6*10 ICD10 008

 +38      ;S DIE="^ABMDCLM(DUZ(2),"

 +39      ;S DA=ABMP("CDFN")

 +40      ;S DR=".022////O"  ;abm*2.6*10 ICD10 008

 +41      ;D ^DIE

 +42      ;end new code 008

 +43      ;end old abm*2.6*21 IHS/SD/SDR HEAT190661

MLI       ;MOVE LINE ITEMS

 +1        SET ABMSTRG=""

 +2        SET DIR(0)="SO^8A:MEDICAL;8B:SURGICAL;8C:REVENUE CODE;8D:RX;8E:LAB;8F:RADIOLOGY;8G:ANESTHESIA;8H:HCPCS;8I:INPATIENT DENTAL;8J:CHARGE MASTER;8Z:ALL"

 +3        SET DIR("A")="Move Which Section(s)? "

 +4        FOR 

               Begin DoDot:1

 +5                DO ^DIR

 +6                IF 'Y

                       QUIT 

 +7                IF ABMSTRG'[Y

                       SET ABMSTRG=ABMSTRG_Y_"^"

 +8                WRITE !!,"Selected: ",$TRANSLATE(ABMSTRG,"^"," ")

               End DoDot:1

               IF 'Y

                   QUIT 

 +9       ;start new abm*2.6*21 IHS/SD/SDR HEAT190661

 +10       IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               WRITE !!,"Split will not occur..."

               HANG 1

               QUIT 

 +11       SET X=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U)

 +12       SET DINUM=$$NXNM^ABMDUTL

 +13       IF DINUM=""

               Begin DoDot:1

 +14               WRITE !!,"ERROR: Claim not created - check global ^ABMDCLM(0)"

 +15               SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

               End DoDot:1

               QUIT 

 +16       KILL DD,DO

           DO FILE^DICN

           IF +Y<0

               QUIT 

           SET ABMC2=+Y

 +17       MERGE ^ABMDCLM(DUZ(2),ABMC2)=^ABMDCLM(DUZ(2),ABMP("CDFN"))

 +18       SET DIE="^ABMDCLM(DUZ(2),"

 +19       SET DA=ABMC2

 +20       SET DR=".1////"_DT_";.04///E"

 +21       SET DR=DR_";.17////"_DT

 +22       SET DR=DR_";.022////S"

 +23       DO ^DIE

 +24       SET DIE="^ABMDCLM(DUZ(2),"

 +25       SET DA=ABMP("CDFN")

 +26       SET DR=".022////O"

 +27       DO ^DIE

 +28      ;end new abm*2.6*21 IHS/SD/SDR HEAT190661

 +29       KILL DIR

 +30       WRITE !

 +31       IF ABMSTRG'["8Z"

               Begin DoDot:1

 +32               SET DIR(0)="Y"

                   SET DIR("A")="Delete sections from original claim after move"

 +33               SET DIR("B")="NO"

 +34               DO ^DIR

                   KILL DIR

 +35               IF Y=1

                       SET ABMDLT=1

               End DoDot:1

 +36       DO DEL

 +37       SET DIK="^ABMDCLM(DUZ(2),"

 +38       FOR DA=ABMC2,ABMP("CDFN")

               Begin DoDot:1

 +39               KILL ^ABMDCLM(DUZ(2),DA,"ASRC")

 +40               DO IX1^DIK

               End DoDot:1

 +41       WRITE !!,"Claim # ",ABMC2," created.",!

 +42       KILL ABMSTRG,ABMDLT,ABMC2,ABMPG,ABMSEC

 +43       SET DIR(0)="E"

           DO ^DIR

           KILL DIR

 +44       QUIT 

DEL       ;DELETE SECTIONS

 +1        KILL ^ABMDCLM(DUZ(2),ABMC2,13)

 +2        FOR I=1:1:10

               Begin DoDot:1

 +3                SET ABMPG=$PIECE("8A^8B^8C^8D^8E^8F^8G^8H^8I^8J","^",I)

 +4                SET ABMSEC=$PIECE("27^21^25^23^37^35^39^43^33^45","^",I)

 +5                IF $GET(ABMDLT)

                       IF ABMSTRG[ABMPG

                           KILL ^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMSEC)

 +6                IF ABMSTRG["8Z"

                       QUIT 

 +7                IF '(ABMSTRG[ABMPG)

                       KILL ^ABMDCLM(DUZ(2),ABMC2,ABMSEC)

               End DoDot:1

 +8        QUIT