ABME8PER.m

ABME8PER ; IHS/ASDST/DMJ - 837 PER Segment 

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

 ;Administrative Communications Contact

 ;

START ;START HERE

 K ABMREC("PER"),ABMR("PER")

 S ABME("RTYPE")="PER"

 D LOOP

 K ABME,ABM

 Q

LOOP ;LOOP HERE

 F I=10:10:100 D

 .D @I

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

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

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

 Q

10 ;segment

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

 Q

20 ;PER01 - Contact Function Code

 S ABMR("PER",20)="IC"

 Q

30 ;PER02 - Name

 S ABMR("PER",30)="BUSINESS OFFICE"

 Q

40 ;PER03 - Communication Number Qualifier

 S ABMR("PER",40)="TE"

 Q

50 ;PER04 - Communication Number

 S ABMR("PER",50)=$P($G(^AUTTLOC(DUZ(2),0)),"^",11)

 S ABMR("PER",50)=$TR(ABMR("PER",50),".-() ")

 Q

60 ;PER05 - Communication Number Qualifier

 S ABMR("PER",60)=""

 Q

70 ;PER06 - Communication Number

 S ABMR("PER",70)=""

 Q

80 ;PER07 - Communication Number Qualifier

 S ABMR("PER",80)=""

 Q

90 ;PER08 - Communication Number

 S ABMR("PER",90)=""

 Q

100 ;PER09 - Contact Inquiry Reference

 S ABMR("PER",100)=""

 Q

ABME8PER  ; IHS/ASDST/DMJ - 837 PER Segment 

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

 +2       ;Administrative Communications Contact

 +3       ;

START     ;START HERE

 +1        KILL ABMREC("PER"),ABMR("PER")

 +2        SET ABME("RTYPE")="PER"

 +3        DO LOOP

 +4        KILL ABME,ABM

 +5        QUIT 

LOOP      ;LOOP HERE

 +1        FOR I=10:10:100

               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("PER"))'=""

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

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

               End DoDot:1

 +6        QUIT 

10        ;segment

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

 +2        QUIT 

20        ;PER01 - Contact Function Code

 +1        SET ABMR("PER",20)="IC"

 +2        QUIT 

30        ;PER02 - Name

 +1        SET ABMR("PER",30)="BUSINESS OFFICE"

 +2        QUIT 

40        ;PER03 - Communication Number Qualifier

 +1        SET ABMR("PER",40)="TE"

 +2        QUIT 

50        ;PER04 - Communication Number

 +1        SET ABMR("PER",50)=$PIECE($GET(^AUTTLOC(DUZ(2),0)),"^",11)

 +2        SET ABMR("PER",50)=$TRANSLATE(ABMR("PER",50),".-() ")

 +3        QUIT 

60        ;PER05 - Communication Number Qualifier

 +1        SET ABMR("PER",60)=""

 +2        QUIT 

70        ;PER06 - Communication Number

 +1        SET ABMR("PER",70)=""

 +2        QUIT 

80        ;PER07 - Communication Number Qualifier

 +1        SET ABMR("PER",80)=""

 +2        QUIT 

90        ;PER08 - Communication Number

 +1        SET ABMR("PER",90)=""

 +2        QUIT 

100       ;PER09 - Contact Inquiry Reference

 +1        SET ABMR("PER",100)=""

 +2        QUIT