Routine: ABMPT259

ABMPT259 ; IHS/ASDST/SDR - 3P BILLING 2.5 Patch 9 POST INIT ;

 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

PREINST ;

EN ; EP

 D ERRCODES ; add new error codes

 D EXPMUDT  ;update export mode with new questions

 D XREF  ;index GROUP CONTROL NUMBER in 3P TX Status file

 D ECODES  ;add new 3P Codes

 D ZNODE  ;populate 0-node for 3P Cancelled Claims Data

 D TCODE  ;Change TRANCODE to TRANSCODE

 D QUES  ;add questions to 3P Page 3 Questions file

 D POSTF  ;populated export mode on past POS claims

 D NEWVT  ;new Visit Type for task 2

 D REINDEX  ;reindex Provider Taxonomy file

 D TPCODES  ;fix entries 1-9 to be 01-09 and re-index

 I $G(^DD(9002274.3021,.18,0))="" D ^ABMPRVCV  ;convert provider to multiple for claims and bills; only do once

 D NEWCRSN  ;new canceled claim reasons

ERRCODES ;

 ;215 - supervising provider missing ID#

 K DIC,X

 S DIC="^ABMDERR("

 S DIC(0)="LM"

 S DINUM=215

 S X="SUPERVISING PROVIDER MISSING ID NUMBER"

 S DIC("DR")=".02///Edit Supervising Provider on page 3 and enter UPIN"

 S DIC("DR")=DIC("DR")_";.03///E"

 K DD,DO

 D FILE^DICN

 D SITE(215)

 ;198 - bill type must be ##5 if delayed reason code is other

 K DIC,X

 S DIC="^ABMDERR("

 S DIC(0)="LM"

 S DINUM=198

 S X="BILL TYPE MUST BE ##5 IF DELAYED REASON CODE IS OTHER"

 S DIC("DR")=".02///Change bill type or delayed reason code"

 S DIC("DR")=DIC("DR")_";.03///W"

 K DD,DO

 D FILE^DICN

 D SITE(198)

 ;214 - delayed reason code with no remarks

 K DIC,X

 S DIC="^ABMDERR("

 S DIC(0)="LM"

 S DINUM=214

 S X="DELAYED REASON CODE WITH NO REMARKS"

 S DIC("DR")=".02///Put remarks on page 9F"

 S DIC("DR")=DIC("DR")_";.03///W"

 K DD,DO

 D FILE^DICN

 D SITE(214)

 ;216 - provider on line item with no address

 K DIC,X

 S DIC="^ABMDERR("

 S DIC(0)="LM"

 S DINUM=216

 S X="PROVIDER ON LINE ITEM WITH NO ADDRESS"

 S DIC("DR")=".02///Add address for provider"

 S DIC("DR")=DIC("DR")_";.03///E"

 K DD,DO

 D FILE^DICN

 D SITE(216)

SITE(ABMX) ;Add SITE multiple

 S DUZHOLD=DUZ(2)

 S DUZ(2)=0

 F  S DUZ(2)=$O(^ABMDCLM(DUZ(2))) Q:'+DUZ(2)  D

 .S DIC(0)="LX"

 .S DA(1)=ABMX

 .S DIC="^ABMDERR("_DA(1)_",31,"

 .S DIC("P")=$P(^DD(9002274.04,31,0),U,2)

 .S DINUM=DUZ(2)

 .S X=$P($G(^DIC(4,DUZ(2),0)),U)

 .S DIC("DR")=".03////E"

 .D ^DIC

 .K DA,DIC,DINUM

 S DUZ(2)=DUZHOLD

 K DUZHOLD,DLAYGO,ABMX

EXPMUDT F ABMEXPM=3,14,15,22 D

 .S ABMQUES=$P($G(^ABMDEXP(ABMEXPM,0)),U,8)

 .Q:ABMQUES["25"

 .S ABMQUES=ABMQUES_",25"

 .S DIE="^ABMDEXP("

 .S DA=ABMEXPM

 .S DR=".08////"_ABMQUES

 .D ^DIE

 F ABMEXPM=21,51 D

 .S ABMQUES=$P($G(^ABMDEXP(ABMEXPM,0)),U,8)

 .Q:ABMQUES["31"

 .S ABMQUES=ABMQUES_",31"

 .S DIE="^ABMDEXP("

 .S DA=ABMEXPM

 .S DR=".08////"_ABMQUES

 .D ^DIE

XREF ;

 K DIC,DIE,DR,DA,X,Y

 S DUZHOLD=DUZ(2)

 S DUZ(2)=0

 F  S DUZ(2)=$O(^ABMDTXST(DUZ(2))) Q:'+DUZ(2)  D

 .S DIK="^ABMDTXST(DUZ(2),"

 .S DIK(1)=".16^C"

 .D ENALL^DIK

 S DUZ(2)=DUZHOLD

ECODES ;

 ; IM14745

 K DIC,X

 S DIC="^ABMDCODE("

 S DIC(0)="ML"

 S X="07"

 S DIC("DR")=".02///H"

 S DIC("DR")=DIC("DR")_";.03///TRIBAL 638 FREE-STANDING FACILITY"

 K DD,DO

 D FILE^DICN

 K DIC,X

 S DIC="^ABMDCODE("

 S DIC(0)="ML"

 S X="08"

 S DIC("DR")=".02///H"

 S DIC("DR")=DIC("DR")_";.03///TRIBAL 638 PROVIDER-BASED FACILITY"

 K DD,DO

 D FILE^DICN

ZNODE ;

 S DUZHOLD=DUZ(2)

 S DUZ(2)=0

 F  S DUZ(2)=$O(^ABMDCLM(DUZ(2))) Q:'+DUZ(2)  D

 .S ABM("GL")="^ABMCCLMS(DUZ(2),0)"

 .S @ABM("GL")=^DIC(9002274.32,0)

 S DUZ(2)=DUZHOLD

 K DUZHOLD,ABM

TCODE ;

 Q:'$D(^ABMPSTAT("B","Trancode missing"))

 S ABMTCODE=$O(^ABMPSTAT("B","Trancode missing",0))

 Q:ABMTCODE=0

 S DIE="^ABMPSTAT("

 S DA=ABMTCODE

 S DR=".01////Transcode missing"

 D ^DIE

QUES ;

 K DIC,X,DINUM,DR,DLAYGO

 S DIC="^ABMQUES("

 S DIC(0)="LM"

 S DLAYGO=9002274

 S DINUM=31,X="DELAYED REASON CODE"

 S DIC("DR")=".02////W31;.03////ABMDE30;.04////31;1////ABMDE3C"

 K DD,DO

 D ^DIC

POSTF ;

 S ABMBDFN=0

 F  S ABMBDFN=$O(^ABMDBILL(DUZ(2),ABMBDFN)) Q:+ABMBDFN=0  D

 .Q:$P($G(^ABMDBILL(DUZ(2),ABMBDFN,0)),U,7)'=901  ;not POS claim

 .S DIE="ABMDBILL(DUZ(2),"

 .S DA=ABMBDFN

 .S DR=".06////24"

 .D ^DIE

NEWVT ;

 ;new visit type for Immunization for task 2

 K DIC,X,DINUM,DR,DLAYGO

 S DIC="^ABMDVTYP("

 S DIC(0)="LM"

 S X="IMMUNIZATION"

 S DINUM=140

 D ^DIC

REINDEX ;EP

 K DIK,DA,DR,DIE,DIC

 S DIK="^ABMPTAX("

 D IXALL^DIK

TPCODES ;

 S ABMCODE=""

 F  S ABMCODE=$O(^ABMDCODE("AC","O",ABMCODE)) Q:ABMCODE=""  D

 .Q:$L(ABMCODE)>1  ;only want 1-digit occurrence codes

 .S ABMCIEN=$O(^ABMDCODE("AC","O",ABMCODE,0))

 .Q:+ABMCIEN=0

 .S DIE="^ABMDCODE("

 .S DA=ABMCIEN

 .S DR=".01////0"_ABMCODE

 .D ^DIE

 S DIK="^ABMDCODE("

 S DIK(1)=".02^AC"

 D ENALL^DIK

NEWCRSN ;

 K DIC,X,DINUM,DR,DLAYGO

 S DIC="^ABMCCLMR("

 S DIC(0)="LM"

 S X="RETURN TO STOCK"

 D ^DIC

 K DIC,X,DINUM,DR,DLAYGO

 S DIC="^ABMCCLMR("

 S DIC(0)="LM"

 S X="OVER THE COUNTER MEDS"

 D ^DIC

 K DIC,X,DINUM,DR,DLAYGO

 S DIC="^ABMCCLMR("

 S DIC(0)="LM"

 S X="LEFT WITHOUT BEING SEEN"

 D ^DIC

 K DIC,X,DINUM,DR,DLAYGO

 S DIC="^ABMCCLMR("

 S DIC(0)="LM"

 S X="TELEPHONE CONSULT"

 D ^DIC

ABMPT259  ; IHS/ASDST/SDR - 3P BILLING 2.5 Patch 9 POST INIT ;

 +1       ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 +2       ;

 +3       ;

 +4        QUIT

PREINST   ;

 +1        QUIT

EN        ; EP

 +1       ; add new error codes

           DO ERRCODES

 +2       ;update export mode with new questions

           DO EXPMUDT

 +3       ;index GROUP CONTROL NUMBER in 3P TX Status file

           DO XREF

 +4       ;add new 3P Codes

           DO ECODES

 +5       ;populate 0-node for 3P Cancelled Claims Data

           DO ZNODE

 +6       ;Change TRANCODE to TRANSCODE

           DO TCODE

 +7       ;add questions to 3P Page 3 Questions file

           DO QUES

 +8       ;populated export mode on past POS claims

           DO POSTF

 +9       ;new Visit Type for task 2

           DO NEWVT

 +10      ;reindex Provider Taxonomy file

           DO REINDEX

 +11      ;fix entries 1-9 to be 01-09 and re-index

           DO TPCODES

 +12      ;convert provider to multiple for claims and bills; only do once

           IF $GET(^DD(9002274.3021,.18,0))=""

               DO ^ABMPRVCV

 +13      ;new canceled claim reasons

           DO NEWCRSN

 +14       QUIT

ERRCODES  ;

 +1       ;215 - supervising provider missing ID#

 +2        KILL DIC,X

 +3        SET DIC="^ABMDERR("

 +4        SET DIC(0)="LM"

 +5        SET DINUM=215

 +6        SET X="SUPERVISING PROVIDER MISSING ID NUMBER"

 +7        SET DIC("DR")=".02///Edit Supervising Provider on page 3 and enter UPIN"

 +8        SET DIC("DR")=DIC("DR")_";.03///E"

 +9        KILL DD,DO

 +10       DO FILE^DICN

 +11       DO SITE(215)

 +12      ;198 - bill type must be ##5 if delayed reason code is other

 +13       KILL DIC,X

 +14       SET DIC="^ABMDERR("

 +15       SET DIC(0)="LM"

 +16       SET DINUM=198

 +17       SET X="BILL TYPE MUST BE ##5 IF DELAYED REASON CODE IS OTHER"

 +18       SET DIC("DR")=".02///Change bill type or delayed reason code"

 +19       SET DIC("DR")=DIC("DR")_";.03///W"

 +20       KILL DD,DO

 +21       DO FILE^DICN

 +22       DO SITE(198)

 +23      ;214 - delayed reason code with no remarks

 +24       KILL DIC,X

 +25       SET DIC="^ABMDERR("

 +26       SET DIC(0)="LM"

 +27       SET DINUM=214

 +28       SET X="DELAYED REASON CODE WITH NO REMARKS"

 +29       SET DIC("DR")=".02///Put remarks on page 9F"

 +30       SET DIC("DR")=DIC("DR")_";.03///W"

 +31       KILL DD,DO

 +32       DO FILE^DICN

 +33       DO SITE(214)

 +34      ;216 - provider on line item with no address

 +35       KILL DIC,X

 +36       SET DIC="^ABMDERR("

 +37       SET DIC(0)="LM"

 +38       SET DINUM=216

 +39       SET X="PROVIDER ON LINE ITEM WITH NO ADDRESS"

 +40       SET DIC("DR")=".02///Add address for provider"

 +41       SET DIC("DR")=DIC("DR")_";.03///E"

 +42       KILL DD,DO

 +43       DO FILE^DICN

 +44       DO SITE(216)

 +45       QUIT

SITE(ABMX) ;Add SITE multiple

 +1        SET DUZHOLD=DUZ(2)

 +2        SET DUZ(2)=0

 +3        FOR

               SET DUZ(2)=$ORDER(^ABMDCLM(DUZ(2)))

               IF '+DUZ(2)

                   QUIT

               Begin DoDot:1

 +4                SET DIC(0)="LX"

 +5                SET DA(1)=ABMX

 +6                SET DIC="^ABMDERR("_DA(1)_",31,"

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

 +8                SET DINUM=DUZ(2)

 +9                SET X=$PIECE($GET(^DIC(4,DUZ(2),0)),U)

 +10               SET DIC("DR")=".03////E"

 +11               DO ^DIC

 +12               KILL DA,DIC,DINUM

               End DoDot:1

 +13       SET DUZ(2)=DUZHOLD

 +14       KILL DUZHOLD,DLAYGO,ABMX

 +15       QUIT

EXPMUDT    FOR ABMEXPM=3,14,15,22

               Begin DoDot:1

 +1                SET ABMQUES=$PIECE($GET(^ABMDEXP(ABMEXPM,0)),U,8)

 +2                IF ABMQUES["25"

                       QUIT

 +3                SET ABMQUES=ABMQUES_",25"

 +4                SET DIE="^ABMDEXP("

 +5                SET DA=ABMEXPM

 +6                SET DR=".08////"_ABMQUES

 +7                DO ^DIE

               End DoDot:1

 +8       ;

 +9        FOR ABMEXPM=21,51

               Begin DoDot:1

 +10               SET ABMQUES=$PIECE($GET(^ABMDEXP(ABMEXPM,0)),U,8)

 +11               IF ABMQUES["31"

                       QUIT

 +12               SET ABMQUES=ABMQUES_",31"

 +13               SET DIE="^ABMDEXP("

 +14               SET DA=ABMEXPM

 +15               SET DR=".08////"_ABMQUES

 +16               DO ^DIE

               End DoDot:1

 +17       QUIT

XREF      ;

 +1        KILL DIC,DIE,DR,DA,X,Y

 +2        SET DUZHOLD=DUZ(2)

 +3        SET DUZ(2)=0

 +4        FOR

               SET DUZ(2)=$ORDER(^ABMDTXST(DUZ(2)))

               IF '+DUZ(2)

                   QUIT

               Begin DoDot:1

 +5                SET DIK="^ABMDTXST(DUZ(2),"

 +6                SET DIK(1)=".16^C"

 +7                DO ENALL^DIK

               End DoDot:1

 +8        SET DUZ(2)=DUZHOLD

 +9        QUIT

ECODES    ;

 +1       ; IM14745

 +2        KILL DIC,X

 +3        SET DIC="^ABMDCODE("

 +4        SET DIC(0)="ML"

 +5        SET X="07"

 +6        SET DIC("DR")=".02///H"

 +7        SET DIC("DR")=DIC("DR")_";.03///TRIBAL 638 FREE-STANDING FACILITY"

 +8        KILL DD,DO

 +9        DO FILE^DICN

 +10       QUIT

 +11       KILL DIC,X

 +12       SET DIC="^ABMDCODE("

 +13       SET DIC(0)="ML"

 +14       SET X="08"

 +15       SET DIC("DR")=".02///H"

 +16       SET DIC("DR")=DIC("DR")_";.03///TRIBAL 638 PROVIDER-BASED FACILITY"

 +17       KILL DD,DO

 +18       DO FILE^DICN

 +19       QUIT

ZNODE     ;

 +1        SET DUZHOLD=DUZ(2)

 +2        SET DUZ(2)=0

 +3        FOR

               SET DUZ(2)=$ORDER(^ABMDCLM(DUZ(2)))

               IF '+DUZ(2)

                   QUIT

               Begin DoDot:1

 +4                SET ABM("GL")="^ABMCCLMS(DUZ(2),0)"

 +5                SET @ABM("GL")=^DIC(9002274.32,0)

               End DoDot:1

 +6        SET DUZ(2)=DUZHOLD

 +7        KILL DUZHOLD,ABM

 +8        QUIT

TCODE     ;

 +1        IF '$DATA(^ABMPSTAT("B","Trancode missing"))

               QUIT

 +2        SET ABMTCODE=$ORDER(^ABMPSTAT("B","Trancode missing",0))

 +3        IF ABMTCODE=0

               QUIT

 +4        SET DIE="^ABMPSTAT("

 +5        SET DA=ABMTCODE

 +6        SET DR=".01////Transcode missing"

 +7        DO ^DIE

 +8        QUIT

QUES      ;

 +1        KILL DIC,X,DINUM,DR,DLAYGO

 +2        SET DIC="^ABMQUES("

 +3        SET DIC(0)="LM"

 +4        SET DLAYGO=9002274

 +5        SET DINUM=31

           SET X="DELAYED REASON CODE"

 +6        SET DIC("DR")=".02////W31;.03////ABMDE30;.04////31;1////ABMDE3C"

 +7        KILL DD,DO

 +8        DO ^DIC

 +9        QUIT

POSTF     ;

 +1        SET ABMBDFN=0

 +2        FOR

               SET ABMBDFN=$ORDER(^ABMDBILL(DUZ(2),ABMBDFN))

               IF +ABMBDFN=0

                   QUIT

               Begin DoDot:1

 +3       ;not POS claim

                   IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMBDFN,0)),U,7)'=901

                       QUIT

 +4                SET DIE="ABMDBILL(DUZ(2),"

 +5                SET DA=ABMBDFN

 +6                SET DR=".06////24"

 +7                DO ^DIE

               End DoDot:1

 +8        QUIT

NEWVT     ;

 +1       ;new visit type for Immunization for task 2

 +2        KILL DIC,X,DINUM,DR,DLAYGO

 +3        SET DIC="^ABMDVTYP("

 +4        SET DIC(0)="LM"

 +5        SET X="IMMUNIZATION"

 +6        SET DINUM=140

 +7        DO ^DIC

 +8        QUIT

REINDEX   ;EP

 +1        KILL DIK,DA,DR,DIE,DIC

 +2        SET DIK="^ABMPTAX("

 +3        DO IXALL^DIK

 +4        QUIT

TPCODES   ;

 +1        SET ABMCODE=""

 +2        FOR

               SET ABMCODE=$ORDER(^ABMDCODE("AC","O",ABMCODE))

               IF ABMCODE=""

                   QUIT

               Begin DoDot:1

 +3       ;only want 1-digit occurrence codes

                   IF $LENGTH(ABMCODE)>1

                       QUIT

 +4                SET ABMCIEN=$ORDER(^ABMDCODE("AC","O",ABMCODE,0))

 +5                IF +ABMCIEN=0

                       QUIT

 +6                SET DIE="^ABMDCODE("

 +7                SET DA=ABMCIEN

 +8                SET DR=".01////0"_ABMCODE

 +9                DO ^DIE

               End DoDot:1

 +10       SET DIK="^ABMDCODE("

 +11       SET DIK(1)=".02^AC"

 +12       DO ENALL^DIK

 +13       QUIT

NEWCRSN   ;

 +1        KILL DIC,X,DINUM,DR,DLAYGO

 +2        SET DIC="^ABMCCLMR("

 +3        SET DIC(0)="LM"

 +4        SET X="RETURN TO STOCK"

 +5        DO ^DIC

 +6        KILL DIC,X,DINUM,DR,DLAYGO

 +7        SET DIC="^ABMCCLMR("

 +8        SET DIC(0)="LM"

 +9        SET X="OVER THE COUNTER MEDS"

 +10       DO ^DIC

 +11       KILL DIC,X,DINUM,DR,DLAYGO

 +12       SET DIC="^ABMCCLMR("

 +13       SET DIC(0)="LM"

 +14       SET X="LEFT WITHOUT BEING SEEN"

 +15       DO ^DIC

 +16       KILL DIC,X,DINUM,DR,DLAYGO

 +17       SET DIC="^ABMCCLMR("

 +18       SET DIC(0)="LM"

 +19       SET X="TELEPHONE CONSULT"

 +20       DO ^DIC

 +21       QUIT

ABMPT259.m