ABMDAST2.m

ABMDAST2 ; IHS/ASDST/DMJ - APC CLAIM STUFF - PART 3 ; 

 ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009

 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to use ABMFEAPI

 ;

PRV S (ABM("X"),ABMP("MD"))=""

 S ABM=0 F  S ABM=$O(^AAPCRCDS(ABMP("VDFN"),5,ABM)) Q:'ABM  S X=$P(^(ABM,0),U) D PRVPRI I ABM("X") S ABMP("MD")=ABM("X") Q

 ;

PRV2 S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",41,",DIC(0)="LE",ABM("O")=0,ABM("A")=0

 S ABM=0 F  S ABM=$O(^AAPCRCDS(ABMP("VDFN"),5,ABM)) Q:'ABM  K DIC("DR"),DD,DO S X=$P(^(ABM,0),U) D PRVCHK

 I 'ABM("A") G ^ABMDAST3

 S X=ABM("A") D PRVPRI I ABM("X")="",ABMP("MD")]"" S ABM("A")=ABMP("MD")

 S X=ABM("A"),ABMR("PX")="A" D PRVST

 I ABM("O") S X=ABM("O"),ABMR("PX")="O" D PRVST I 1

 E  I ABMP("VTYP")=111!($G(ABMP("BTYP"))=111),+$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),21,0)) S X=ABM("A"),ABMR("PX")="O" D PRVST

OP I ABMP("MD") S:'$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),27,0)) ^ABMDCLM(DUZ(2),ABMP("CDFN"),27,0)="^9002274.3027P"

 ;start old code abm*2.6*2 3PMS10003A

 ;I  S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,",DIC(0)="LE",(DINUM,X)=$S($D(^ICPT(99211)):99211,1:90030),DIC("DR")=".03////1;.04////"_$P($G(^ABMDFEE(ABMP("FEE"),19,X,0)),U,2) K DD,DO D FILE^DICN

 ;end old code start new code 3PMS10003A

 I  S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,",DIC(0)="LE",(DINUM,X)=$S($D(^ICPT(99211)):99211,1:90030),DIC("DR")=".03////1;.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,($S($G(ABMP("VDT")):ABMP("VDT"),1:DT))),U) K DD,DO D FILE^DICN

 ;end new code 3PMS10003A

 G ^ABMDAST3

 ;

PRVCHK I 'ABM("A") S ABM("A")=X

 Q

 ;

PRVST I $D(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"C",ABMR("PX")))=10 Q

 S DIC("P")=$P(^DD(9002274.3,41,0),U,2)

 S DIC("DR")=".02////"_ABMR("PX") K DD,DO D FILE^DICN

 Q

 ;

PRVPRI ;NEEDS TO BE CHANGED WHEN & IF APC CONVERTS TO FILE 200

 S ABM("X")=""

 Q

ABMDAST2  ; IHS/ASDST/DMJ - APC CLAIM STUFF - PART 3 ; 

 +1       ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009

 +2       ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to use ABMFEAPI

 +3       ;

PRV        SET (ABM("X"),ABMP("MD"))=""

 +1        SET ABM=0

           FOR 

               SET ABM=$ORDER(^AAPCRCDS(ABMP("VDFN"),5,ABM))

               IF 'ABM

                   QUIT 

               SET X=$PIECE(^(ABM,0),U)

               DO PRVPRI

               IF ABM("X")

                   SET ABMP("MD")=ABM("X")

                   QUIT 

 +2       ;

PRV2       SET DA(1)=ABMP("CDFN")

           SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",41,"

           SET DIC(0)="LE"

           SET ABM("O")=0

           SET ABM("A")=0

 +1        SET ABM=0

           FOR 

               SET ABM=$ORDER(^AAPCRCDS(ABMP("VDFN"),5,ABM))

               IF 'ABM

                   QUIT 

               KILL DIC("DR"),DD,DO

               SET X=$PIECE(^(ABM,0),U)

               DO PRVCHK

 +2        IF 'ABM("A")

               GOTO ^ABMDAST3

 +3        SET X=ABM("A")

           DO PRVPRI

           IF ABM("X")=""

               IF ABMP("MD")]""

                   SET ABM("A")=ABMP("MD")

 +4        SET X=ABM("A")

           SET ABMR("PX")="A"

           DO PRVST

 +5        IF ABM("O")

               SET X=ABM("O")

               SET ABMR("PX")="O"

               DO PRVST

               IF 1

 +6       IF '$TEST

               IF ABMP("VTYP")=111!($GET(ABMP("BTYP"))=111)

                   IF +$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),21,0))

                       SET X=ABM("A")

                       SET ABMR("PX")="O"

                       DO PRVST

OP         IF ABMP("MD")

               IF '$DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),27,0))

                   SET ^ABMDCLM(DUZ(2),ABMP("CDFN"),27,0)="^9002274.3027P"

 +1       ;start old code abm*2.6*2 3PMS10003A

 +2       ;I  S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,",DIC(0)="LE",(DINUM,X)=$S($D(^ICPT(99211)):99211,1:90030),DIC("DR")=".03////1;.04////"_$P($G(^ABMDFEE(ABMP("FEE"),19,X,0)),U,2) K DD,DO D FILE^DICN

 +3       ;end old code start new code 3PMS10003A

 +4       IF $TEST

               SET DA(1)=ABMP("CDFN")

               SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,"

               SET DIC(0)="LE"

               SET (DINUM,X)=$SELECT($DATA(^ICPT(99211)):99211,1:90030)

               SET DIC("DR")=".03////1;.04////"_$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),19,X,($SELECT($GET(ABMP("VDT")):ABMP("VDT"),1:DT))),U)

               KILL DD,DO

               DO FILE^DICN

 +5       ;end new code 3PMS10003A

 +6        GOTO ^ABMDAST3

 +7       ;

PRVCHK     IF 'ABM("A")

               SET ABM("A")=X

 +1        QUIT 

 +2       ;

PRVST      IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"C",ABMR("PX")))=10

               QUIT 

 +1        SET DIC("P")=$PIECE(^DD(9002274.3,41,0),U,2)

 +2        SET DIC("DR")=".02////"_ABMR("PX")

           KILL DD,DO

           DO FILE^DICN

 +3        QUIT 

 +4       ;

PRVPRI    ;NEEDS TO BE CHANGED WHEN & IF APC CONVERTS TO FILE 200

 +1        SET ABM("X")=""

 +2        QUIT