ABME5TOO.m

ABME5TOO ; IHS/ASDST/DMJ - 837 TOO Segment 

 ;;2.6;IHS Third Party Billing System;**6,19**;NOV 12, 2009;Build 300

 ;Tooth Identification

 ;IHS/SD/SDR - 2.6*19 - HEAT180453 - Updated TOO02 for some of the codes being sent, mostly the ones with 'X' or 'Q'

 ;  as the final character.

 ;

 ;EP - START HERE

 K ABMREC("TOO"),ABMR("TOO")

 S ABME("RTYPE")="TOO"

 D LOOP

 K ABME,ABM

 Q

LOOP ;LOOP HERE

 F I=10:10:40 D

 .D @I

 .I $D(^ABMEXLM("AA",+$G(ABMP("INS")),+$G(ABMP("EXP")),ABME("RTYPE"),I)) D @(^(I))

 .I $G(ABMREC("TOO"))'="" S ABMREC("TOO")=ABMREC("TOO")_"*"

 .S ABMREC("TOO")=$G(ABMREC("TOO"))_ABMR("TOO",I)

 Q

10 ;segment

 S ABMR("TOO",10)="TOO"

 Q

20 ;TOO01 - Code List Qualifier Code

 S ABMR("TOO",20)="JP"

 Q

30 ;TOO02 - Tooth Number

 N I

 S I=$P(ABMRV(ABMI,ABMJ,ABMK),U,23)

 S ABMR("TOO",30)=$G(^ADEOPS(+I,88))

 ;start new abm*2.6*19 IHS/SD/SDR HEAT180453

 I ABMR("TOO",30)="MND" S ABMR("TOO",30)="02"

 I ABMR("TOO",30)="MAX" S ABMR("TOO",30)="01"

 I ABMR("TOO",30)="OT" S ABMR("TOO",30)="09"

 I ABMR("TOO",30)="LLQ" S ABMR("TOO",30)="30"

 I ABMR("TOO",30)="LRQ" S ABMR("TOO",30)="40"

 I ABMR("TOO",30)="ULQ" S ABMR("TOO",30)="20"

 I ABMR("TOO",30)="URQ" S ABMR("TOO",30)="10"

 I ABMR("TOO",30)="LAX" S ABMR("TOO",30)="07"

 I ABMR("TOO",30)="LLX" S ABMR("TOO",30)="06"

 I ABMR("TOO",30)="LRX" S ABMR("TOO",30)="08"

 I ABMR("TOO",30)="UAX" S ABMR("TOO",30)="04"

 I ABMR("TOO",30)="ULX" S ABMR("TOO",30)="05"

 I ABMR("TOO",30)="URX" S ABMR("TOO",30)="03"

 ;end new abm*2.6*19 IHS/SD/SDR HEAT180453

 Q

40 ;TOO03 - Tooth Surface

 N I,J

 S I=$P(ABMRV(ABMI,ABMJ,ABMK),U,24)

 I I="" S ABMR("TOO",40)="" Q

 F J=1:1:$L(I) D

 .S $P(ABMR("TOO",40),":",J)=$E(I,J)

 Q

ABME5TOO  ; IHS/ASDST/DMJ - 837 TOO Segment 

 +1       ;;2.6;IHS Third Party Billing System;**6,19**;NOV 12, 2009;Build 300

 +2       ;Tooth Identification

 +3       ;IHS/SD/SDR - 2.6*19 - HEAT180453 - Updated TOO02 for some of the codes being sent, mostly the ones with 'X' or 'Q'

 +4       ;  as the final character.

 +5       ;

 +6       ;EP - START HERE

 +7        KILL ABMREC("TOO"),ABMR("TOO")

 +8        SET ABME("RTYPE")="TOO"

 +9        DO LOOP

 +10       KILL ABME,ABM

 +11       QUIT 

LOOP      ;LOOP HERE

 +1        FOR I=10:10:40

               Begin DoDot:1

 +2                DO @I

 +3                IF $DATA(^ABMEXLM("AA",+$GET(ABMP("INS")),+$GET(ABMP("EXP")),ABME("RTYPE"),I))

                       DO @(^(I))

 +4                IF $GET(ABMREC("TOO"))'=""

                       SET ABMREC("TOO")=ABMREC("TOO")_"*"

 +5                SET ABMREC("TOO")=$GET(ABMREC("TOO"))_ABMR("TOO",I)

               End DoDot:1

 +6        QUIT 

10        ;segment

 +1        SET ABMR("TOO",10)="TOO"

 +2        QUIT 

20        ;TOO01 - Code List Qualifier Code

 +1        SET ABMR("TOO",20)="JP"

 +2        QUIT 

30        ;TOO02 - Tooth Number

 +1        NEW I

 +2        SET I=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,23)

 +3        SET ABMR("TOO",30)=$GET(^ADEOPS(+I,88))

 +4       ;start new abm*2.6*19 IHS/SD/SDR HEAT180453

 +5        IF ABMR("TOO",30)="MND"

               SET ABMR("TOO",30)="02"

 +6        IF ABMR("TOO",30)="MAX"

               SET ABMR("TOO",30)="01"

 +7        IF ABMR("TOO",30)="OT"

               SET ABMR("TOO",30)="09"

 +8        IF ABMR("TOO",30)="LLQ"

               SET ABMR("TOO",30)="30"

 +9        IF ABMR("TOO",30)="LRQ"

               SET ABMR("TOO",30)="40"

 +10       IF ABMR("TOO",30)="ULQ"

               SET ABMR("TOO",30)="20"

 +11       IF ABMR("TOO",30)="URQ"

               SET ABMR("TOO",30)="10"

 +12       IF ABMR("TOO",30)="LAX"

               SET ABMR("TOO",30)="07"

 +13       IF ABMR("TOO",30)="LLX"

               SET ABMR("TOO",30)="06"

 +14       IF ABMR("TOO",30)="LRX"

               SET ABMR("TOO",30)="08"

 +15       IF ABMR("TOO",30)="UAX"

               SET ABMR("TOO",30)="04"

 +16       IF ABMR("TOO",30)="ULX"

               SET ABMR("TOO",30)="05"

 +17       IF ABMR("TOO",30)="URX"

               SET ABMR("TOO",30)="03"

 +18      ;end new abm*2.6*19 IHS/SD/SDR HEAT180453

 +19       QUIT 

40        ;TOO03 - Tooth Surface

 +1        NEW I,J

 +2        SET I=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,24)

 +3        IF I=""

               SET ABMR("TOO",40)=""

               QUIT 

 +4        FOR J=1:1:$LENGTH(I)

               Begin DoDot:1

 +5                SET $PIECE(ABMR("TOO",40),":",J)=$EXTRACT(I,J)

               End DoDot:1

 +6        QUIT