ABMPT268.m

ABMPT268 ; IHS/SD/SDR - 3P BILLING 2.6 Patch 8 POST INIT ;  

 ;;2.6;IHS Third Party Billing;**8**;NOV 12, 2009

 ;

 Q

POST ;

 D EXP31

 D EXP33

 D ERRCODES

 D PRVCLASS

 D CHRGSUMM

 D MUCONV

 Q

EXP31 ;

 K DIC,DR,DINUM,DLAYGO,DIE

 S DIC="^ABMDEXP("

 S DIC(0)="LM"

 S DLAYGO=9002274

 S X="837I (UB) 5010",DINUM=31

 K DD,DO

 D ^DIC

 Q:Y<0

 S DA=+Y

 S DIE="^ABMDEXP("

 S DR=".04////ABMEF31;.07///837 5010 INSTITUTIONAL;.08///1,2,3,4,5,6,8,14,19,21,22,23,24,28,31;.11////ABMDES1;.15///E"

 D ^DIE

EXP33 ;

 K DIC,DR,DINUM,DLAYGO,DIE

 S DIC="^ABMDEXP("

 S DIC(0)="LM"

 S DLAYGO=9002274

 S X="837D (ADA) 5010",DINUM=33

 K DD,DO

 D ^DIC

 Q:Y<0

 S DA=+Y

 S DIE="^ABMDEXP("

 S DR=".04////ABMEF33;.07///837 5010 DENTAL;.08///1,2,3,4B,5,14,16,17,18,19,28,34,35;.11////ABMDES3;.15///E"

 D ^DIE

 Q

ERRCODES ;

 ;240 - POA VALUE '1' NOT APPLICABLE FOR THIS EXPORT MODE

 K DIC,X

 S DIC="^ABMDERR("

 S DIC(0)="LM"

 S DINUM=240

 S X="POA VALUE '1' NOT APPLICABLE FOR THIS EXPORT MODE"

 S DIC("DR")=".02///Select different POA Value"

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

 K DD,DO

 D FILE^DICN

 D SITE(240)

 Q

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

 Q

 ;

PRVCLASS ;

 F ABMI=1:1 S ABMLN=$P($T(PCLASS+ABMI),";;",2) Q:ABMLN="END"  D

 .S DA(1)=1

 .S DIC="^ABMMUPRM("_DA(1)_",2,"

 .S DIC(0)="QLM"

 .S X=$P(ABMLN,U)

 .D ^DIC

 Q

PCLASS ;

 ;;00^PHYSICIAN

 ;;11^PHYSICIAN ASSISTANT

 ;;16^PEDIATRIC NURSE PRACT.

 ;;17^NURSE MIDWIFE

 ;;18^PHYSICIAN (CONTRACT)

 ;;21^NURSE PRACTITIONER

 ;;41^OB/GYN (CONTRACT)

 ;;44^PHYSICIAN (TRIBAL)

 ;;45^OSTEOPATH

 ;;49^CONTRACT PSYCHIATRIST

 ;;52^DENTIST

 ;;64^NEPHROLOGIST

 ;;68^EMERGENCY ROOM PHYSICIAN

 ;;70^CARDIOLOGIST

 ;;71^INTERNAL MEDICINE

 ;;72^OB/GYN

 ;;73^ORTHOPEDIST

 ;;74^OTOLARYNGOLOGIST

 ;;75^PEDIATRICIAN

 ;;76^RADIOLOGIST

 ;;77^SURGEON

 ;;78^UROLOGIST

 ;;79^OPHTHALMOLOGIST

 ;;80^FAMILY PRACTICE

 ;;81^PSYCHIATRIST

 ;;82^ANESTHESIOLOGIST

 ;;83^PATHOLOGIST

 ;;85^NEUROLOGIST

 ;;86^DERMATOLOGIST

 ;;A1^SPORTS MEDICINE PHYSICIAN

 ;;A9^HEPATOLOGIST

 ;;B1^GASTROENTEROLOGIST

 ;;B2^ENDOCRINOLOGIST

 ;;B3^RHEUMATOLOGIST

 ;;B4^ONCOLOGIST-HEMATOLOGIST

 ;;B5^PULMONOLOGIST

 ;;B6^NEUROSURGEON

 ;;END

CHRGSUMM ;

 S DIE="^ABMDEXP("

 S DR=".11////ABMDES4"

 F DA=23,33 D

 .D ^DIE

 Q

MUCONV ;

 S ABMIEN=0

 F  S ABMIEN=$O(^ABMMUPRM(1,1,ABMIEN)) Q:'ABMIEN  D

 .S ABMLOC=+$P($G(^ABMMUPRM(1,1,ABMIEN,0)),U)

 .Q:'$D(^ABMMUPRM(1,1,ABMLOC))

 .S $P(^ABMMUPRM(1,1,ABMIEN,0),U,2)=$P($G(^ABMMUPRM(1,1,ABMLOC,0)),U,2)

 .S DA(1)=1

 .S DA=ABMLOC

 .S DIK="^ABMMUPRM("_DA(1)_",1,"

 .D ^DIK

 Q

ABMPT268  ; IHS/SD/SDR - 3P BILLING 2.6 Patch 8 POST INIT ;  

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

 +2       ;

 +3        QUIT 

POST      ;

 +1        DO EXP31

 +2        DO EXP33

 +3        DO ERRCODES

 +4        DO PRVCLASS

 +5        DO CHRGSUMM

 +6        DO MUCONV

 +7        QUIT 

EXP31     ;

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

 +2        SET DIC="^ABMDEXP("

 +3        SET DIC(0)="LM"

 +4        SET DLAYGO=9002274

 +5        SET X="837I (UB) 5010"

           SET DINUM=31

 +6        KILL DD,DO

 +7        DO ^DIC

 +8        IF Y<0

               QUIT 

 +9        SET DA=+Y

 +10       SET DIE="^ABMDEXP("

 +11       SET DR=".04////ABMEF31;.07///837 5010 INSTITUTIONAL;.08///1,2,3,4,5,6,8,14,19,21,22,23,24,28,31;.11////ABMDES1;.15///E"

 +12       DO ^DIE

EXP33     ;

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

 +2        SET DIC="^ABMDEXP("

 +3        SET DIC(0)="LM"

 +4        SET DLAYGO=9002274

 +5        SET X="837D (ADA) 5010"

           SET DINUM=33

 +6        KILL DD,DO

 +7        DO ^DIC

 +8        IF Y<0

               QUIT 

 +9        SET DA=+Y

 +10       SET DIE="^ABMDEXP("

 +11       SET DR=".04////ABMEF33;.07///837 5010 DENTAL;.08///1,2,3,4B,5,14,16,17,18,19,28,34,35;.11////ABMDES3;.15///E"

 +12       DO ^DIE

 +13       QUIT 

ERRCODES  ;

 +1       ;240 - POA VALUE '1' NOT APPLICABLE FOR THIS EXPORT MODE

 +2        KILL DIC,X

 +3        SET DIC="^ABMDERR("

 +4        SET DIC(0)="LM"

 +5        SET DINUM=240

 +6        SET X="POA VALUE '1' NOT APPLICABLE FOR THIS EXPORT MODE"

 +7        SET DIC("DR")=".02///Select different POA Value"

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

 +9        KILL DD,DO

 +10       DO FILE^DICN

 +11       DO SITE(240)

 +12       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 

 +16      ;

PRVCLASS  ;

 +1        FOR ABMI=1:1

               SET ABMLN=$PIECE($TEXT(PCLASS+ABMI),";;",2)

               IF ABMLN="END"

                   QUIT 

               Begin DoDot:1

 +2                SET DA(1)=1

 +3                SET DIC="^ABMMUPRM("_DA(1)_",2,"

 +4                SET DIC(0)="QLM"

 +5                SET X=$PIECE(ABMLN,U)

 +6                DO ^DIC

               End DoDot:1

 +7        QUIT 

PCLASS    ;

 +1       ;;00^PHYSICIAN

 +2       ;;11^PHYSICIAN ASSISTANT

 +3       ;;16^PEDIATRIC NURSE PRACT.

 +4       ;;17^NURSE MIDWIFE

 +5       ;;18^PHYSICIAN (CONTRACT)

 +6       ;;21^NURSE PRACTITIONER

 +7       ;;41^OB/GYN (CONTRACT)

 +8       ;;44^PHYSICIAN (TRIBAL)

 +9       ;;45^OSTEOPATH

 +10      ;;49^CONTRACT PSYCHIATRIST

 +11      ;;52^DENTIST

 +12      ;;64^NEPHROLOGIST

 +13      ;;68^EMERGENCY ROOM PHYSICIAN

 +14      ;;70^CARDIOLOGIST

 +15      ;;71^INTERNAL MEDICINE

 +16      ;;72^OB/GYN

 +17      ;;73^ORTHOPEDIST

 +18      ;;74^OTOLARYNGOLOGIST

 +19      ;;75^PEDIATRICIAN

 +20      ;;76^RADIOLOGIST

 +21      ;;77^SURGEON

 +22      ;;78^UROLOGIST

 +23      ;;79^OPHTHALMOLOGIST

 +24      ;;80^FAMILY PRACTICE

 +25      ;;81^PSYCHIATRIST

 +26      ;;82^ANESTHESIOLOGIST

 +27      ;;83^PATHOLOGIST

 +28      ;;85^NEUROLOGIST

 +29      ;;86^DERMATOLOGIST

 +30      ;;A1^SPORTS MEDICINE PHYSICIAN

 +31      ;;A9^HEPATOLOGIST

 +32      ;;B1^GASTROENTEROLOGIST

 +33      ;;B2^ENDOCRINOLOGIST

 +34      ;;B3^RHEUMATOLOGIST

 +35      ;;B4^ONCOLOGIST-HEMATOLOGIST

 +36      ;;B5^PULMONOLOGIST

 +37      ;;B6^NEUROSURGEON

 +38      ;;END

CHRGSUMM  ;

 +1        SET DIE="^ABMDEXP("

 +2        SET DR=".11////ABMDES4"

 +3        FOR DA=23,33

               Begin DoDot:1

 +4                DO ^DIE

               End DoDot:1

 +5        QUIT 

MUCONV    ;

 +1        SET ABMIEN=0

 +2        FOR 

               SET ABMIEN=$ORDER(^ABMMUPRM(1,1,ABMIEN))

               IF 'ABMIEN

                   QUIT 

               Begin DoDot:1

 +3                SET ABMLOC=+$PIECE($GET(^ABMMUPRM(1,1,ABMIEN,0)),U)

 +4                IF '$DATA(^ABMMUPRM(1,1,ABMLOC))

                       QUIT 

 +5                SET $PIECE(^ABMMUPRM(1,1,ABMIEN,0),U,2)=$PIECE($GET(^ABMMUPRM(1,1,ABMLOC,0)),U,2)

 +6                SET DA(1)=1

 +7                SET DA=ABMLOC

 +8                SET DIK="^ABMMUPRM("_DA(1)_",1,"

 +9                DO ^DIK

               End DoDot:1

 +10       QUIT