ACKQAG06.m

ACKQAG06        ;DDC/PJU - AUDIOGRAM UTILITY FOR ACKQAG01 ;7/13/05

 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02

GETDATA(ACKQI,ACKI)    ;called from ACKQAG01- Puts values in ACKQARR()

 ;input the entry number in the Audiometic Exam Data file (ACKQI)

 ;and current return array subscript value by reference(.ACKI)

 ;ACKQA1=air initial threshold

 ;ACKQA2=air REPEAT THRESHOLD

 ;ACKQA3=air FINAL THRESHOLD

 ;ACKQAML=AIR MASK LEVEL

 ;ACKQB1=bone initial threshold

 ;ACKQB2=bone REPEAT THRESHOLD

 ;ACKQB3=bone FINAL THRESHOLD

 ;ACKQBML=bone MASK level

 ;P=piece of the air nodes, P1=piece of the bone nodes

 ;SB=Bone node, X is the Hz reading to start and then a string holding variable

 ;X1 is a string holding variable, I is an integer used for looping

 ;S0 is a node holder

 N ACKQA1,ACKQA2,ACKQA3,ACKQAML

 N ACKQB1,ACKQB2,ACKQB3,ACKQBML

 N I,P,P1,S0,SB,X,X1

RA F P=1:1:12 D  ;R ear Air

 .S (ACKQA1,ACKQA2,ACKQA3,ACKQAML,ACKQB1,ACKQB2,ACKQB3,ACKQBML)=""

 .S ACKI=ACKI+1 ;counter subscript for array

 .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"")

 .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")

 .S ACKQARR(ACKI)=X_U_ACKQI_U_"R"_U Q:ACKI=12  ;12 node used for repeat test data

 .S ACKQA1=$P($G(^ACK(509850.9,ACKQI,10)),U,P) ;init val

 .S ACKQA2=$P($G(^ACK(509850.9,ACKQI,15)),U,P) ;RETEST val

 .S ACKQA3=$P($G(^ACK(509850.9,ACKQI,20)),U,P) ;FINAL val

 .S ACKQAML=$P($G(^ACK(509850.9,ACKQI,51)),U,P) ;MASK level

 .S:ACKQAML="CNM" ACKQAML=""

 .S $P(ACKQARR(ACKI),U,4)="" ;default air Y

 .S $P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete

 .S $P(ACKQARR(ACKI),U,6)="" ;default mask level

 .D LOGIC(ACKQA1,ACKQA2,ACKQA3,ACKQAML,"A") ;Air Conduction

RB .;

 .I X>125,X<7000 D  ;R bone conduction

 ..S P1=P-1 ;125 not a bone reading so pc's 1 less

 ..S ACKQB1=$P($G(^ACK(509850.9,ACKQI,70)),U,P1) ;init bone

 ..S ACKQB2=$P($G(^ACK(509850.9,ACKQI,72)),U,P1) ;RETEST bone

 ..S ACKQB3=$P($G(^ACK(509850.9,ACKQI,75)),U,P1) ;FINAL bone

 ..S ACKQBML=$P($G(^ACK(509850.9,ACKQI,91)),U,P1) ;bone MASK level

 ..S $P(ACKQARR(ACKI),U,7)="" ;default bone Y

 ..S $P(ACKQARR(ACKI),U,8)="" ;default mask *** obsolete

 ..S $P(ACKQARR(ACKI),U,9)="" ;default mask level

 ..D LOGIC(ACKQB1,ACKQB2,ACKQB3,ACKQBML,"B") ;bone conduction rules

RIAR .;IAR R

 .S SB=$G(^ACK(509850.9,ACKQI,120))

 .I (X=500) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,4) ;R IAR500

 .E  I (X=1000) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,5) ;R IAR1000

 .E  I (X=2000) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,6) ;R IAR2000

 .E  I (X=4000) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,7) ;R IAR4000

RCAR  .;CAR

 .S SB=$G(^ACK(509850.9,ACKQI,121))

 .I (X=500) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,8) ;R CAR500

 .E  I (X=1000) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,9) ;R CAR1000

 .E  I (X=2000) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,10) ;R CAR2000

 .E  I (X=4000) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,11) ;R CAR4000

 ;

LA F P=1:1:12 D  ;L ear air

 .S (ACKQA1,ACKQA2,ACKQA3,ACKQAML,ACKQB1,ACKQB2,ACKQB3,ACKQBML)=""

 .S ACKI=ACKI+1 ;counter subscript for array

 .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"")

 .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")

 .S ACKQARR(ACKI)=X_U_ACKQI_U_"L"_U Q:ACKI=24  ;24 node used for speech test data

 .S ACKQA1=$P($G(^ACK(509850.9,ACKQI,30)),U,P) ;init val

 .S ACKQA2=$P($G(^ACK(509850.9,ACKQI,35)),U,P) ;RETEST val

 .S ACKQA3=$P($G(^ACK(509850.9,ACKQI,40)),U,P) ;FINAL val

 .S ACKQAML=$P($G(^ACK(509850.9,ACKQI,61)),U,P) ;MASK level

 .S:ACKQAML="CNM" ACKQAML=""

 .S $P(ACKQARR(ACKI),U,4)="" ;default air Y

 .S $P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete

 .S $P(ACKQARR(ACKI),U,6)="" ;default mask level

 .D LOGIC(ACKQA1,ACKQA2,ACKQA3,ACKQAML,"A") ;Air Conduction

 .;

LB .I X>125,X<7000 D  ;L bone conduction

 ..S P1=P-1 ;125 not a bone reading so pc's 1 less

 ..S ACKQB1=$P($G(^ACK(509850.9,ACKQI,80)),U,P1) ;init bone

 ..S ACKQB2=$P($G(^ACK(509850.9,ACKQI,82)),U,P1) ;RETEST bone

 ..S ACKQB3=$P($G(^ACK(509850.9,ACKQI,85)),U,P1) ;FINAL bone

 ..S ACKQBML=$P($G(^ACK(509850.9,ACKQI,101)),U,P1) ;bone MASK level

 ..S $P(ACKQARR(ACKI),U,7)="" ;default bone Y

 ..S $P(ACKQARR(ACKI),U,8)="" ;default mask *** obsolete

 ..S $P(ACKQARR(ACKI),U,9)="" ;default mask level

 ..D LOGIC(ACKQB1,ACKQB2,ACKQB3,ACKQBML,"B") ;bone conduction rules

LIAR .;IAR L

 .S SB=$G(^ACK(509850.9,ACKQI,121))

 .I (X=500) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,4) ;L IAR500

 .I (X=1000) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,5) ;L IAR1000

 .I (X=2000) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,6) ;L IAR2000

 .I (X=4000) D

 ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,7) ;L IAR4000

LCAR .;CAR L

 .S SB=$G(^ACK(509850.9,ACKQI,120))

 .I (X=500) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,8) ;L CAR500

 .I (X=1000) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,9) ;L CAR1000

 .I (X=2000) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,10) ;L CAR2000

 .I (X=4000) D

 ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,11) ;L CAR4000

SPCH ;next lines are only done 1 time for the table (2364)

 S ACKI=25 ;25 node- first 10 pc's are word %

 S S0=$G(^ACK(509850.9,ACKQI,110)) D  ;R speech

 .F I=1:1:5 S $P(ACKQARR(25),U,I)=$P(S0,U,(4+(5*(I-1))))

 ;S X="" F I=3:5:23 S X=$P(S0,U,I) Q:$L(X)

 S X=$P(S0,U,3)

 I $L(X) D

 .S X1="" I (X=3)!(X=6) S X1="CNC"

 .I (X=2)!(X=5) S X1="CIDW"

 .E  I (X=1)!(X=4) S X1="NU"

 .S:X1="" X1="OTHER"

 .S $P(ACKQARR(25),U,17)=X1 ;MATERIAL R

 ;S X="" F I=5:5:25 S X=$P(S0,U,I) Q:$L(X)

 S X=$P(S0,U,5)

 I $L(X) D

 .S X1="" I (X=1)!(X=2) S X1="REC"

 .I (X=3) S X1="MLV"

 .S $P(ACKQARR(25),U,18)=X1 ;PRES METH R

 ;

 S J=20,X="" F I=28:1:32 S X=$P(S0,U,I) D

 .;S X1=""

 .;S:X=3 X1="25" S:X=6 X1="50" ;CNC

 .;S:X=2 X1="25" S:X=5 X1="50" ;W22

 .;S:X=1 X1="25" S:X=4 X1="50" ;NU

 .;S:X1=7 X1="OTH"

 .S J=J+1

 .S $P(ACKQARR(25),U,J)=X ;LISTS R

 ;

 S S0=$G(^ACK(509850.9,ACKQI,111)) D  ;L Speech

 .F I=1:1:5 D

 ..S J=I+5 S $P(ACKQARR(25),U,J)=$P(S0,U,(4+(5*(I-1))))

 S X="" F I=3:5:23 S X=$P(S0,U,I) Q:$L(X)

 I $L(X) D

 .S X1="" I (X=3)!(X=6) S X1="CNC"

 .I (X=2)!(X=5) S X1="CIDW"

 .I (X=1)!(X=4) S X1="NU"

 .S:X1="" X1="OTHER"

 .S $P(ACKQARR(25),U,19)=X1 ;Material L if 3*3

 S X="" F I=5:5:25 S X=$P(S0,U,I) Q:$L(X)

 I $L(X) D

 .S X1="" I (X=1)!(X=2) S X1="REC"

 .E  I (X=3) S X1="MLV"

 .S $P(ACKQARR(25),U,20)=X1 ;PRES METH R

 ;

 S J=25 F I=28:1:32 S X=$P(S0,U,I) D

 .;S X1=""

 .;S:X=3 X1="25" S:X=6 X1="50" ;CNC

 .;S:X=2 X1="25" S:X=5 X1="50" ;W22

 .;S:X=1 X1="25" S:X=4 X1="50" ;NU

 .;S:X1=7 X1="OTH"

 .S J=J+1

 .S $P(ACKQARR(25),U,J)=X ;LISTS L

 ;

 S S0=$G(^ACK(509850.9,ACKQI,115))

 S $P(ACKQARR(25),U,11)=$P(S0,U,9),$P(ACKQARR(25),U,12)=$P(S0,U,11) ;R MAX & PIPB

 S $P(ACKQARR(25),U,14)=$P(S0,U,12),$P(ACKQARR(25),U,15)=$P(S0,U,14) ;L MAX & PIPB

SRT ;next section lines go in array nodes 24 only

 S $P(ACKQARR(24),U,31)=$P(S0,U,1) ;SRT R1

 S $P(ACKQARR(24),U,32)=$P(S0,U,2) ;SRT R2

 S $P(ACKQARR(24),U,35)=$P(S0,U,3) ;R init SRT Mask Lev

 S $P(ACKQARR(24),U,36)=$P(S0,U,4) ;R final SRT Mask Lev

 S $P(ACKQARR(24),U,33)=$P(S0,U,5) ;SRT L1

 S $P(ACKQARR(24),U,34)=$P(S0,U,6) ;SRT L2

 S $P(ACKQARR(24),U,37)=$P(S0,U,7) ;L init SRT Mask Lev

 S $P(ACKQARR(24),U,38)=$P(S0,U,8) ;L final SRT Mask Lev

 S $P(ACKQARR(24),U,39)=$P(S0,U,17) ;R SRT initial tag

 S $P(ACKQARR(24),U,40)=$P(S0,U,18) ;L SRT initial tag

 S $P(ACKQARR(24),U,41)=$P(S0,U,15) ;R SRT final tag

 S $P(ACKQARR(24),U,42)=$P(S0,U,16) ;L SRT final tag

ITC S S0=$G(^ACK(509850.9,ACKQI,120)),X=$P(S0,U,16) ;additions to 25 node

 S $P(ACKQARR(25),U,13)=$S(X=1:"GOOD",X=2:"FAIR",X=3:"POOR",1:"") ;R consistency

 S SB=$G(^ACK(509850.9,ACKQI,121)),X=$P(SB,U,16)

 S $P(ACKQARR(25),U,16)=$S(X=1:"GOOD",X=2:"FAIR",X=3:"POOR",1:"") ;L consistency

REF ;set referral reason,source & transducer type into node 24

 S S0=$G(^ACK(509850.9,ACKQI,0)) ;additions to 24 node

 S $P(ACKQARR(24),U,1)=$P(S0,U,7) ;TYPE OF VISIT

 S X1="" S X=$P(S0,U,4) I X S X1=$P($G(^SC(X,0)),U,1) ;referral source

 S $P(ACKQARR(24),U,2)=X1 ;referral source

 S X1=$P(S0,U,8),$P(ACKQARR(24),U,3)=X1 ;transducer type

 Q

 ;

LOGIC(R1,R2,R3,ML,AB)     ;

 ;Chart logic:

 ;R1=init read-R1

 ;R2=repeat read-R2

 ;R3=FINAL read-R3

 ;ML=MASK level-ML

 ;AB=air or bone

 ;defaults set above: (BONE IS 7,8,9)

 ;$P(ACKQARR(ACKI),U,4)="" ;default air Y

 ;$P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete

 ;$P(ACKQARR(ACKI),U,6)="" ;default mask level

 I (R1="DNT")!(R1="CNT") Q  ;leave at "" if not tested

 I R3'="" D  Q  ;masked, value in R3 (R3 could contain +)

 .S:AB="A" $P(ACKQARR(ACKI),U,4)=R3,$P(ACKQARR(ACKI),U,6)=ML

 .S:AB="B" $P(ACKQARR(ACKI),U,7)=R3,$P(ACKQARR(ACKI),U,9)=ML

 I R2="" D SET1 Q

 I R1="" D SET2 Q

 I R1["+",R2'["+" D SET2 Q

 I R1'["+",R2["+" D SET1 Q

 I R1<R2 D SET1 Q

 E  D SET2

 Q

SET1 ;

 S:AB="A" $P(ACKQARR(ACKI),U,4)=R1,$P(ACKQARR(ACKI),U,6)=ML

 S:AB="B" $P(ACKQARR(ACKI),U,7)=R1,$P(ACKQARR(ACKI),U,9)=ML

 Q

SET2 ;

 S:AB="A" $P(ACKQARR(ACKI),U,4)=R2,$P(ACKQARR(ACKI),U,6)=ML

 S:AB="B" $P(ACKQARR(ACKI),U,7)=R2,$P(ACKQARR(ACKI),U,9)=ML

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ACKQAG06   9110     printed  Mar 13, 2025@21:36:38                                                                                                                                                                                                    Page 2

ACKQAG06  ;DDC/PJU - AUDIOGRAM UTILITY FOR ACKQAG01 ;7/13/05

 +1       ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02

GETDATA(ACKQI,ACKI) ;called from ACKQAG01- Puts values in ACKQARR()

 +1       ;input the entry number in the Audiometic Exam Data file (ACKQI)

 +2       ;and current return array subscript value by reference(.ACKI)

 +3       ;ACKQA1=air initial threshold

 +4       ;ACKQA2=air REPEAT THRESHOLD

 +5       ;ACKQA3=air FINAL THRESHOLD

 +6       ;ACKQAML=AIR MASK LEVEL

 +7       ;ACKQB1=bone initial threshold

 +8       ;ACKQB2=bone REPEAT THRESHOLD

 +9       ;ACKQB3=bone FINAL THRESHOLD

 +10      ;ACKQBML=bone MASK level

 +11      ;P=piece of the air nodes, P1=piece of the bone nodes

 +12      ;SB=Bone node, X is the Hz reading to start and then a string holding variable

 +13      ;X1 is a string holding variable, I is an integer used for looping

 +14      ;S0 is a node holder

 +15       NEW ACKQA1,ACKQA2,ACKQA3,ACKQAML

 +16       NEW ACKQB1,ACKQB2,ACKQB3,ACKQBML

 +17       NEW I,P,P1,S0,SB,X,X1

RA        ;R ear Air

           FOR P=1:1:12

               Begin DoDot:1

 +1                SET (ACKQA1,ACKQA2,ACKQA3,ACKQAML,ACKQB1,ACKQB2,ACKQB3,ACKQBML)=""

 +2       ;counter subscript for array

                   SET ACKI=ACKI+1

 +3                SET X=$SELECT(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"")

 +4                if X=""

                       SET X=$SELECT(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")

 +5       ;12 node used for repeat test data

                   SET ACKQARR(ACKI)=X_U_ACKQI_U_"R"_U

                   if ACKI=12

                       QUIT 

 +6       ;init val

                   SET ACKQA1=$PIECE($GET(^ACK(509850.9,ACKQI,10)),U,P)

 +7       ;RETEST val

                   SET ACKQA2=$PIECE($GET(^ACK(509850.9,ACKQI,15)),U,P)

 +8       ;FINAL val

                   SET ACKQA3=$PIECE($GET(^ACK(509850.9,ACKQI,20)),U,P)

 +9       ;MASK level

                   SET ACKQAML=$PIECE($GET(^ACK(509850.9,ACKQI,51)),U,P)

 +10               if ACKQAML="CNM"

                       SET ACKQAML=""

 +11      ;default air Y

                   SET $PIECE(ACKQARR(ACKI),U,4)=""

 +12      ;default mask *** obsolete

                   SET $PIECE(ACKQARR(ACKI),U,5)=""

 +13      ;default mask level

                   SET $PIECE(ACKQARR(ACKI),U,6)=""

 +14      ;Air Conduction

                   DO LOGIC(ACKQA1,ACKQA2,ACKQA3,ACKQAML,"A")

RB        ;

 +1       ;R bone conduction

                   IF X>125

                       IF X<7000

                           Begin DoDot:2

 +2       ;125 not a bone reading so pc's 1 less

                               SET P1=P-1

 +3       ;init bone

                               SET ACKQB1=$PIECE($GET(^ACK(509850.9,ACKQI,70)),U,P1)

 +4       ;RETEST bone

                               SET ACKQB2=$PIECE($GET(^ACK(509850.9,ACKQI,72)),U,P1)

 +5       ;FINAL bone

                               SET ACKQB3=$PIECE($GET(^ACK(509850.9,ACKQI,75)),U,P1)

 +6       ;bone MASK level

                               SET ACKQBML=$PIECE($GET(^ACK(509850.9,ACKQI,91)),U,P1)

 +7       ;default bone Y

                               SET $PIECE(ACKQARR(ACKI),U,7)=""

 +8       ;default mask *** obsolete

                               SET $PIECE(ACKQARR(ACKI),U,8)=""

 +9       ;default mask level

                               SET $PIECE(ACKQARR(ACKI),U,9)=""

 +10      ;bone conduction rules

                               DO LOGIC(ACKQB1,ACKQB2,ACKQB3,ACKQBML,"B")

                           End DoDot:2

RIAR      ;IAR R

 +1                SET SB=$GET(^ACK(509850.9,ACKQI,120))

 +2                IF (X=500)

                       Begin DoDot:2

 +3       ;R IAR500

                           SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,4)

                       End DoDot:2

 +4               IF '$TEST

                       IF (X=1000)

                           Begin DoDot:2

 +5       ;R IAR1000

                               SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,5)

                           End DoDot:2

 +6               IF '$TEST

                       IF (X=2000)

                           Begin DoDot:2

 +7       ;R IAR2000

                               SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,6)

                           End DoDot:2

 +8               IF '$TEST

                       IF (X=4000)

                           Begin DoDot:2

 +9       ;R IAR4000

                               SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,7)

                           End DoDot:2

RCAR      ;CAR

 +1                SET SB=$GET(^ACK(509850.9,ACKQI,121))

 +2                IF (X=500)

                       Begin DoDot:2

 +3       ;R CAR500

                           SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,8)

                       End DoDot:2

 +4               IF '$TEST

                       IF (X=1000)

                           Begin DoDot:2

 +5       ;R CAR1000

                               SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,9)

                           End DoDot:2

 +6               IF '$TEST

                       IF (X=2000)

                           Begin DoDot:2

 +7       ;R CAR2000

                               SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,10)

                           End DoDot:2

 +8               IF '$TEST

                       IF (X=4000)

                           Begin DoDot:2

 +9       ;R CAR4000

                               SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,11)

                           End DoDot:2

               End DoDot:1

 +10      ;

LA        ;L ear air

           FOR P=1:1:12

               Begin DoDot:1

 +1                SET (ACKQA1,ACKQA2,ACKQA3,ACKQAML,ACKQB1,ACKQB2,ACKQB3,ACKQBML)=""

 +2       ;counter subscript for array

                   SET ACKI=ACKI+1

 +3                SET X=$SELECT(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"")

 +4                if X=""

                       SET X=$SELECT(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")

 +5       ;24 node used for speech test data

                   SET ACKQARR(ACKI)=X_U_ACKQI_U_"L"_U

                   if ACKI=24

                       QUIT 

 +6       ;init val

                   SET ACKQA1=$PIECE($GET(^ACK(509850.9,ACKQI,30)),U,P)

 +7       ;RETEST val

                   SET ACKQA2=$PIECE($GET(^ACK(509850.9,ACKQI,35)),U,P)

 +8       ;FINAL val

                   SET ACKQA3=$PIECE($GET(^ACK(509850.9,ACKQI,40)),U,P)

 +9       ;MASK level

                   SET ACKQAML=$PIECE($GET(^ACK(509850.9,ACKQI,61)),U,P)

 +10               if ACKQAML="CNM"

                       SET ACKQAML=""

 +11      ;default air Y

                   SET $PIECE(ACKQARR(ACKI),U,4)=""

 +12      ;default mask *** obsolete

                   SET $PIECE(ACKQARR(ACKI),U,5)=""

 +13      ;default mask level

                   SET $PIECE(ACKQARR(ACKI),U,6)=""

 +14      ;Air Conduction

                   DO LOGIC(ACKQA1,ACKQA2,ACKQA3,ACKQAML,"A")

 +15      ;

LB        ;L bone conduction

                   IF X>125

                       IF X<7000

                           Begin DoDot:2

 +1       ;125 not a bone reading so pc's 1 less

                               SET P1=P-1

 +2       ;init bone

                               SET ACKQB1=$PIECE($GET(^ACK(509850.9,ACKQI,80)),U,P1)

 +3       ;RETEST bone

                               SET ACKQB2=$PIECE($GET(^ACK(509850.9,ACKQI,82)),U,P1)

 +4       ;FINAL bone

                               SET ACKQB3=$PIECE($GET(^ACK(509850.9,ACKQI,85)),U,P1)

 +5       ;bone MASK level

                               SET ACKQBML=$PIECE($GET(^ACK(509850.9,ACKQI,101)),U,P1)

 +6       ;default bone Y

                               SET $PIECE(ACKQARR(ACKI),U,7)=""

 +7       ;default mask *** obsolete

                               SET $PIECE(ACKQARR(ACKI),U,8)=""

 +8       ;default mask level

                               SET $PIECE(ACKQARR(ACKI),U,9)=""

 +9       ;bone conduction rules

                               DO LOGIC(ACKQB1,ACKQB2,ACKQB3,ACKQBML,"B")

                           End DoDot:2

LIAR      ;IAR L

 +1                SET SB=$GET(^ACK(509850.9,ACKQI,121))

 +2                IF (X=500)

                       Begin DoDot:2

 +3       ;L IAR500

                           SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,4)

                       End DoDot:2

 +4                IF (X=1000)

                       Begin DoDot:2

 +5       ;L IAR1000

                           SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,5)

                       End DoDot:2

 +6                IF (X=2000)

                       Begin DoDot:2

 +7       ;L IAR2000

                           SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,6)

                       End DoDot:2

 +8                IF (X=4000)

                       Begin DoDot:2

 +9       ;L IAR4000

                           SET $PIECE(ACKQARR(ACKI),U,10)=$PIECE(SB,U,7)

                       End DoDot:2

LCAR      ;CAR L

 +1                SET SB=$GET(^ACK(509850.9,ACKQI,120))

 +2                IF (X=500)

                       Begin DoDot:2

 +3       ;L CAR500

                           SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,8)

                       End DoDot:2

 +4                IF (X=1000)

                       Begin DoDot:2

 +5       ;L CAR1000

                           SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,9)

                       End DoDot:2

 +6                IF (X=2000)

                       Begin DoDot:2

 +7       ;L CAR2000

                           SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,10)

                       End DoDot:2

 +8                IF (X=4000)

                       Begin DoDot:2

 +9       ;L CAR4000

                           SET $PIECE(ACKQARR(ACKI),U,11)=$PIECE(SB,U,11)

                       End DoDot:2

               End DoDot:1

SPCH      ;next lines are only done 1 time for the table (2364)

 +1       ;25 node- first 10 pc's are word %

           SET ACKI=25

 +2       ;R speech

           SET S0=$GET(^ACK(509850.9,ACKQI,110))

           Begin DoDot:1

 +3            FOR I=1:1:5

                   SET $PIECE(ACKQARR(25),U,I)=$PIECE(S0,U,(4+(5*(I-1))))

           End DoDot:1

 +4       ;S X="" F I=3:5:23 S X=$P(S0,U,I) Q:$L(X)

 +5        SET X=$PIECE(S0,U,3)

 +6        IF $LENGTH(X)

               Begin DoDot:1

 +7                SET X1=""

                   IF (X=3)!(X=6)

                       SET X1="CNC"

 +8                IF (X=2)!(X=5)

                       SET X1="CIDW"

 +9               IF '$TEST

                       IF (X=1)!(X=4)

                           SET X1="NU"

 +10               if X1=""

                       SET X1="OTHER"

 +11      ;MATERIAL R

                   SET $PIECE(ACKQARR(25),U,17)=X1

               End DoDot:1

 +12      ;S X="" F I=5:5:25 S X=$P(S0,U,I) Q:$L(X)

 +13       SET X=$PIECE(S0,U,5)

 +14       IF $LENGTH(X)

               Begin DoDot:1

 +15               SET X1=""

                   IF (X=1)!(X=2)

                       SET X1="REC"

 +16               IF (X=3)

                       SET X1="MLV"

 +17      ;PRES METH R

                   SET $PIECE(ACKQARR(25),U,18)=X1

               End DoDot:1

 +18      ;

 +19       SET J=20

           SET X=""

           FOR I=28:1:32

               SET X=$PIECE(S0,U,I)

               Begin DoDot:1

 +20      ;S X1=""

 +21      ;S:X=3 X1="25" S:X=6 X1="50" ;CNC

 +22      ;S:X=2 X1="25" S:X=5 X1="50" ;W22

 +23      ;S:X=1 X1="25" S:X=4 X1="50" ;NU

 +24      ;S:X1=7 X1="OTH"

 +25               SET J=J+1

 +26      ;LISTS R

                   SET $PIECE(ACKQARR(25),U,J)=X

               End DoDot:1

 +27      ;

 +28      ;L Speech

           SET S0=$GET(^ACK(509850.9,ACKQI,111))

           Begin DoDot:1

 +29           FOR I=1:1:5

                   Begin DoDot:2

 +30                   SET J=I+5

                       SET $PIECE(ACKQARR(25),U,J)=$PIECE(S0,U,(4+(5*(I-1))))

                   End DoDot:2

           End DoDot:1

 +31       SET X=""

           FOR I=3:5:23

               SET X=$PIECE(S0,U,I)

               if $LENGTH(X)

                   QUIT 

 +32       IF $LENGTH(X)

               Begin DoDot:1

 +33               SET X1=""

                   IF (X=3)!(X=6)

                       SET X1="CNC"

 +34               IF (X=2)!(X=5)

                       SET X1="CIDW"

 +35               IF (X=1)!(X=4)

                       SET X1="NU"

 +36               if X1=""

                       SET X1="OTHER"

 +37      ;Material L if 3*3

                   SET $PIECE(ACKQARR(25),U,19)=X1

               End DoDot:1

 +38       SET X=""

           FOR I=5:5:25

               SET X=$PIECE(S0,U,I)

               if $LENGTH(X)

                   QUIT 

 +39       IF $LENGTH(X)

               Begin DoDot:1

 +40               SET X1=""

                   IF (X=1)!(X=2)

                       SET X1="REC"

 +41              IF '$TEST

                       IF (X=3)

                           SET X1="MLV"

 +42      ;PRES METH R

                   SET $PIECE(ACKQARR(25),U,20)=X1

               End DoDot:1

 +43      ;

 +44       SET J=25

           FOR I=28:1:32

               SET X=$PIECE(S0,U,I)

               Begin DoDot:1

 +45      ;S X1=""

 +46      ;S:X=3 X1="25" S:X=6 X1="50" ;CNC

 +47      ;S:X=2 X1="25" S:X=5 X1="50" ;W22

 +48      ;S:X=1 X1="25" S:X=4 X1="50" ;NU

 +49      ;S:X1=7 X1="OTH"

 +50               SET J=J+1

 +51      ;LISTS L

                   SET $PIECE(ACKQARR(25),U,J)=X

               End DoDot:1

 +52      ;

 +53       SET S0=$GET(^ACK(509850.9,ACKQI,115))