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 ---[H[J[2J[HACKQAG06 9110 printed Apr 09, 2024@21:34:47 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))
+54 ;R MAX & PIPB
SET $PIECE(ACKQARR(25),U,11)=$PIECE(S0,U,9)
SET $PIECE(ACKQARR(25),U,12)=$PIECE(S0,U,11)
+55 ;L MAX & PIPB
SET $PIECE(ACKQARR(25),U,14)=$PIECE(S0,U,12)
SET $PIECE(ACKQARR(25),U,15)=$PIECE(S0,U,14)
SRT ;next section lines go in array nodes 24 only
+1 ;SRT R1
SET $PIECE(ACKQARR(24),U,31)=$PIECE(S0,U,1)
+2 ;SRT R2
SET $PIECE(ACKQARR(24),U,32)=$PIECE(S0,U,2)
+3 ;R init SRT Mask Lev
SET $PIECE(ACKQARR(24),U,35)=$PIECE(S0,U,3)
+4 ;R final SRT Mask Lev
SET $PIECE(ACKQARR(24),U,36)=$PIECE(S0,U,4)
+5 ;SRT L1
SET $PIECE(ACKQARR(24),U,33)=$PIECE(S0,U,5)
+6 ;SRT L2
SET $PIECE(ACKQARR(24),U,34)=$PIECE(S0,U,6)
+7 ;L init SRT Mask Lev
SET $PIECE(ACKQARR(24),U,37)=$PIECE(S0,U,7)
+8 ;L final SRT Mask Lev
SET $PIECE(ACKQARR(24),U,38)=$PIECE(S0,U,8)
+9 ;R SRT initial tag
SET $PIECE(ACKQARR(24),U,39)=$PIECE(S0,U,17)
+10 ;L SRT initial tag
SET $PIECE(ACKQARR(24),U,40)=$PIECE(S0,U,18)
+11 ;R SRT final tag
SET $PIECE(ACKQARR(24),U,41)=$PIECE(S0,U,15)
+12 ;L SRT final tag
SET $PIECE(ACKQARR(24),U,42)=$PIECE(S0,U,16)
ITC ;additions to 25 node
SET S0=$GET(^ACK(509850.9,ACKQI,120))
SET X=$PIECE(S0,U,16)
+1 ;R consistency
SET $PIECE(ACKQARR(25),U,13)=$SELECT(X=1:"GOOD",X=2:"FAIR",X=3:"POOR",1:"")
+2 SET SB=$GET(^ACK(509850.9,ACKQI,121))
SET X=$PIECE(SB,U,16)
+3 ;L consistency
SET $PIECE(ACKQARR(25),U,16)=$SELECT(X=1:"GOOD",X=2:"FAIR",X=3:"POOR",1:"")
REF ;set referral reason,source & transducer type into node 24
+1 ;additions to 24 node
SET S0=$GET(^ACK(509850.9,ACKQI,0))
+2 ;TYPE OF VISIT
SET $PIECE(ACKQARR(24),U,1)=$PIECE(S0,U,7)
+3 ;referral source
SET X1=""
SET X=$PIECE(S0,U,4)
IF X
SET X1=$PIECE($GET(^SC(X,0)),U,1)
+4 ;referral source
SET $PIECE(ACKQARR(24),U,2)=X1
+5 ;transducer type
SET X1=$PIECE(S0,U,8)
SET $PIECE(ACKQARR(24),U,3)=X1
+6 QUIT
+7 ;
LOGIC(R1,R2,R3,ML,AB) ;
+1 ;Chart logic:
+2 ;R1=init read-R1
+3 ;R2=repeat read-R2
+4 ;R3=FINAL read-R3
+5 ;ML=MASK level-ML
+6 ;AB=air or bone
+7 ;defaults set above: (BONE IS 7,8,9)
+8 ;$P(ACKQARR(ACKI),U,4)="" ;default air Y
+9 ;$P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete
+10 ;$P(ACKQARR(ACKI),U,6)="" ;default mask level
+11 ;leave at "" if not tested
IF (R1="DNT")!(R1="CNT")
QUIT
+12 ;masked, value in R3 (R3 could contain +)
IF R3'=""
Begin DoDot:1
+13 if AB="A"
SET $PIECE(ACKQARR(ACKI),U,4)=R3
SET $PIECE(ACKQARR(ACKI),U,6)=ML
+14 if AB="B"
SET $PIECE(ACKQARR(ACKI),U,7)=R3
SET $PIECE(ACKQARR(ACKI),U,9)=ML
End DoDot:1
QUIT
+15 IF R2=""
DO SET1
QUIT
+16 IF R1=""
DO SET2
QUIT
+17 IF R1["+"
IF R2'["+"
DO SET2
QUIT
+18 IF R1'["+"
IF R2["+"
DO SET1
QUIT
+19 IF R1<R2
DO SET1
QUIT
+20 IF '$TEST
DO SET2
+21 QUIT
SET1 ;
+1 if AB="A"
SET $PIECE(ACKQARR(ACKI),U,4)=R1
SET $PIECE(ACKQARR(ACKI),U,6)=ML
+2 if AB="B"
SET $PIECE(ACKQARR(ACKI),U,7)=R1
SET $PIECE(ACKQARR(ACKI),U,9)=ML
+3 QUIT
SET2 ;
+1 if AB="A"
SET $PIECE(ACKQARR(ACKI),U,4)=R2
SET $PIECE(ACKQARR(ACKI),U,6)=ML
+2 if AB="B"
SET $PIECE(ACKQARR(ACKI),U,7)=R2
SET $PIECE(ACKQARR(ACKI),U,9)=ML
+3 QUIT
