ABME8TOO.m

ABME8TOO ; IHS/ASDST/DMJ - 837 TOO Segment 

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

 ;Tooth Identification

 ;

 ; IHS/SD/SDR - v2.5 p10 - IM20395

 ;   Split out lines bundled by rev code

 ;

 ;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))

 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

ABME8TOO  ; IHS/ASDST/DMJ - 837 TOO Segment 

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

 +2       ;Tooth Identification

 +3       ;

 +4       ; IHS/SD/SDR - v2.5 p10 - IM20395

 +5       ;   Split out lines bundled by rev code

 +6       ;

 +7       ;EP - START HERE

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

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

 +10       DO LOOP

 +11       KILL ABME,ABM

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