ACKQAG02 ;DDC/PJU - Module to get data for Audiogram E/E and Transmit to DDC ;07/21/05
;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
;input: ref to array and DFN
;return: array of VALUES in ACKQARR, ACKQERR if an error was found
;Called by RPC ACKQAUD2
;Used by the the E/E - One Audiogram at a time
;IEN needed in 1st pc for the Enter/edit program
;ACKQARR(1)=audiogram local ien^name of patient^last date seen^tester1^error msg
;ACKQARR(ctr)=pcs in rest of counter nodes
; 1=Xvalue
; 2=ear[L,R]
; 3=
; 4=iAirY
; 5=iAirMask[0-6]-not used in 3*12
; 6=iAirMaskL
; 7=iBoneY
; 8=iBoneMask[0-1]-not used in 3*12
; 9=iBoneMaskL
; 10=IAR
; 11=CAR
; 12=fAirY
; 13=fAirMask[0-6]-not used in 3*12
; 14=fAirMaskL
; 15=fBoneY
; 16=fBoneMask[0-1]-not used in 3*12
; 17=fBoneMaskL
; 18=AR DECAY
; 19=HALF LF
;will return to the Delphi app as subscripted array
;subscripts: 1(gen), 2-13(R), 14-25(L), 26(gen)
START(ACKQARR,DFN) ;
K ACKQERR
;ACKQN is a number counter, S0 is a node holder
;ACKQERR is an error holder
;ACKQFMD hold dates, ACKQ1IEN holds the entry number
I '$G(DFN) D G END
.S ACKQERR="**ERROR** Must have a DFN to run routine RMPFRPC2 "
I '$D(^ACK(509850.9,0)) D G END
.S ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available"
;look up DFN in file
I '$D(^ACK(509850.9,"DFN",DFN)) D G END
.S ACKQERR="**ERROR** patient not in audiogram file"
;determine if 1 or 2 audiograms - set flag
S ACKQFMD="A",ACKQ1IEN=""
S1 S ACKQFMD=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD),-1)
;set up array for latest one in file
I 'ACKQFMD D G END
.S ACKQERR="**ERROR** No current audiograms for patient in file"
S ACKQIEN=0
S2 S ACKQIEN=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD,ACKQIEN))
I 'ACKQIEN D G S1
.S ACKQERR="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQFMD)
I '$D(^ACK(509850.9,ACKQIEN,0)) D G S1
.S ACKQERR="**ERROR** Node missing in file for this visit"
G EN2 ;to skip following line
EN(ACKQARR,ACKQIEN,DFN) ;
EN2 ;from S2
N ACK,ACKD,ACKDF,ACKT
S ACKQARR(1)=0 ;default
K ACKQERR F I=2:1:25 S ACKQARR(I)=""
S S0=$S(ACKQIEN="":"",1:$G(^ACK(509850.9,ACKQIEN,0))) ;HD63875
I S0="" S ACKQFMD="A" G S1 ;HD63875
I $P(S0,U,2)'=DFN D G S2 ;should be already checked in calling routine
.S ACKQERR="***URGENT ERROR*** File error - wrong DFN in xref DFN or record: "_DFN
S DIC=2,DA=DFN,DIQ="AK",DR=".01" D EN^DIQ1 S ACKD=AK(2,DFN,.01) ;DFN name
K DIC,DA,DIQ,DR,AK
;(1)=ien^patient^FM date seen^tester
S ACKDF=$P(^ACK(509850.9,ACKQIEN,0),U,1)
S ACKQARR(1)=ACKQIEN_U_ACKD_U_ACKDF
I '$P(S0,U,3) S $P(ACKQARR(1),U,4)="Unknown"
E D
.S Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(Y) K Y
.S $P(ACKQARR(1),U,4)=$P(X,U,1) ;tester name
D GETDATA(ACKQIEN)
END ;if errors, then handle errors and stop
S:'$D(ACKQARR(1)) ACKQARR(1)=0
I $G(ACKQERR)'="" D D WRTERR ;5th pc of 0 node is err msg
.F I=2:1:25 S ACKQARR(I)=""
K ACKQERR,ACKQFMD,I,S0
Q
;
GETDATA(ACKQIEN) ;
;input the entry number in the Audiometic Exam Data file (ACKQIEN)
;and current return array subscript value(ACKQN)
N ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L ;air initial & repeat values, air tags initial & repeat, air Mask Levels
N ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L ;bone initial & repeat values, bone masking init & repeat
N P,P1 ;P is the piece of the air nodes, P1 is the piece of the bone nodes
N X ;X is the Hz
S ACKQN=1 ;counter subscript for array - subsc 1 filled in above
;START R ear
; Air
F P=1:1:12 D ;set pcs in ACKQARR node
.S ACKQN=ACKQN+1
.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(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y
.S ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,10)),U,P) ;init Y val
.S ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,11)),U,P) ;init tag
.S ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,50)),U,P) ;init tag level
.S ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,20)),U,P) ;repeat val
.S ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,21)),U,P) ;repeat tag
.S ACKQA2L=$P($G(^ACK(509850.9,ACKQIEN,51)),U,P) ;repeat tag level
.S $P(ACKQARR(ACKQN),U,4)=ACKQA1,$P(ACKQARR(ACKQN),U,5)=ACKQA1T ;default
.S $P(ACKQARR(ACKQN),U,6)=ACKQA1L,$P(ACKQARR(ACKQN),U,12)=ACKQA2
.S $P(ACKQARR(ACKQN),U,13)=ACKQA2T,$P(ACKQARR(ACKQN),U,14)=ACKQA2L
.; bone conduction
.I X>125,X<7000 D
..S P1=P-1 ;125 not a bone reading so pc's 1 less
..S ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,70)),U,P1) ;init bone
..S ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,71)),U,P1) ;init bone TAG
..S ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,90)),U,P1) ;init bone level
..S ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,75)),U,P1) ;repeat bone
..S ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,76)),U,P1) ;repeat bone TAG
..S ACKQB2L=$P($G(^ACK(509850.9,ACKQIEN,91)),U,P1) ;repeat bone mask
..S $P(ACKQARR(ACKQN),U,7)=ACKQB1,$P(ACKQARR(ACKQN),U,8)=ACKQB1T
..S $P(ACKQARR(ACKQN),U,9)=ACKQB1L,$P(ACKQARR(ACKQN),U,15)=ACKQB2
..S $P(ACKQARR(ACKQN),U,16)=ACKQB2T,$P(ACKQARR(ACKQN),U,17)=ACKQB2L
.;IAR/CAR AR-DECAY AR-HALFLIFE
.I (X=500) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,4)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,8)
..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,12)
..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,14)
.I (X=1000) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,5)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,9)
..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,13)
..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,15)
.I (X=2000) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,6)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,10)
.I (X=4000) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,7)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,11)
;start L ear
; air
F P=1:1:12 D
.S ACKQN=ACKQN+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,1:"")
.S:X="" X=$S(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000)
.S ACKQARR(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y
.S ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,30)),U,P) ;initial read null
.S ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,31)),U,P) ;init tag
.S ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,60)),U,P) ;init level
.S ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,40)),U,P) ;repeat val
.S ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,41)),U,P) ;repeat tag
.S ACKQA2L=$P($G(^ACK(509850.9,ACKQIEN,61)),U,P) ;repeat level
.S $P(ACKQARR(ACKQN),U,4)=ACKQA1,$P(ACKQARR(ACKQN),U,5)=ACKQA1T
.; bone conduction
.I X>125,X<7000 D
..S P1=P-1 ;125 not a bone reading so pc's 1 less
..S ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,80)),U,P1) ;init val
..S ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,81)),U,P1) ;init tag
..S ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,100)),U,P1) ;init mask level
..S ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,85)),U,P1) ;repeat val
..S ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,86)),U,P1) ;repeat tag
..S ACKQB2L=$P($G(^ACK(509850.9,ACKQIEN,101)),U,P1) ;repeat mask level
..S $P(ACKQARR(ACKQN),U,7)=ACKQB1,$P(ACKQARR(ACKQN),U,8)=ACKQB1T ;default
..S $P(ACKQARR(ACKQN),U,9)=ACKQB1L,$P(ACKQARR(ACKQN),U,15)=ACKQB2
..S $P(ACKQARR(ACKQN),U,16)=ACKQB2T,$P(ACKQARR(ACKQN),U,17)=ACKQB2L
.; IAR/CAR AR-DECAY AR-HALFLIFE
.I (X=500) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,4)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,8)
..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,12)
..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,14)
.I (X=1000) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,5)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,9)
..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,12)
..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,14)
.I (X=2000) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,6)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,10)
.I (X=4000) D
..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,7)
..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,11)
Q
;
WRTERR ;
I $L($G(ACKQERR)) D
.S $P(ACKQARR(1),U,5)=ACKQERR ;
;W !!,?10,ACKQERR ;used for direct call testing
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQAG02 8534 printed Nov 22, 2024@17:41:34 Page 2
ACKQAG02 ;DDC/PJU - Module to get data for Audiogram E/E and Transmit to DDC ;07/21/05
+1 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
+2 ;input: ref to array and DFN
+3 ;return: array of VALUES in ACKQARR, ACKQERR if an error was found
+4 ;Called by RPC ACKQAUD2
+5 ;Used by the the E/E - One Audiogram at a time
+6 ;IEN needed in 1st pc for the Enter/edit program
+7 ;ACKQARR(1)=audiogram local ien^name of patient^last date seen^tester1^error msg
+8 ;ACKQARR(ctr)=pcs in rest of counter nodes
+9 ; 1=Xvalue
+10 ; 2=ear[L,R]
+11 ; 3=
+12 ; 4=iAirY
+13 ; 5=iAirMask[0-6]-not used in 3*12
+14 ; 6=iAirMaskL
+15 ; 7=iBoneY
+16 ; 8=iBoneMask[0-1]-not used in 3*12
+17 ; 9=iBoneMaskL
+18 ; 10=IAR
+19 ; 11=CAR
+20 ; 12=fAirY
+21 ; 13=fAirMask[0-6]-not used in 3*12
+22 ; 14=fAirMaskL
+23 ; 15=fBoneY
+24 ; 16=fBoneMask[0-1]-not used in 3*12
+25 ; 17=fBoneMaskL
+26 ; 18=AR DECAY
+27 ; 19=HALF LF
+28 ;will return to the Delphi app as subscripted array
+29 ;subscripts: 1(gen), 2-13(R), 14-25(L), 26(gen)
START(ACKQARR,DFN) ;
+1 KILL ACKQERR
+2 ;ACKQN is a number counter, S0 is a node holder
+3 ;ACKQERR is an error holder
+4 ;ACKQFMD hold dates, ACKQ1IEN holds the entry number
+5 IF '$GET(DFN)
Begin DoDot:1
+6 SET ACKQERR="**ERROR** Must have a DFN to run routine RMPFRPC2 "
End DoDot:1
GOTO END
+7 IF '$DATA(^ACK(509850.9,0))
Begin DoDot:1
+8 SET ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available"
End DoDot:1
GOTO END
+9 ;look up DFN in file
+10 IF '$DATA(^ACK(509850.9,"DFN",DFN))
Begin DoDot:1
+11 SET ACKQERR="**ERROR** patient not in audiogram file"
End DoDot:1
GOTO END
+12 ;determine if 1 or 2 audiograms - set flag
+13 SET ACKQFMD="A"
SET ACKQ1IEN=""
S1 SET ACKQFMD=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQFMD),-1)
+1 ;set up array for latest one in file
+2 IF 'ACKQFMD
Begin DoDot:1
+3 SET ACKQERR="**ERROR** No current audiograms for patient in file"
End DoDot:1
GOTO END
+4 SET ACKQIEN=0
S2 SET ACKQIEN=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQFMD,ACKQIEN))
+1 IF 'ACKQIEN
Begin DoDot:1
+2 SET ACKQERR="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQFMD)
End DoDot:1
GOTO S1
+3 IF '$DATA(^ACK(509850.9,ACKQIEN,0))
Begin DoDot:1
+4 SET ACKQERR="**ERROR** Node missing in file for this visit"
End DoDot:1
GOTO S1
+5 ;to skip following line
GOTO EN2
EN(ACKQARR,ACKQIEN,DFN) ;
EN2 ;from S2
+1 NEW ACK,ACKD,ACKDF,ACKT
+2 ;default
SET ACKQARR(1)=0
+3 KILL ACKQERR
FOR I=2:1:25
SET ACKQARR(I)=""
+4 ;HD63875
SET S0=$SELECT(ACKQIEN="":"",1:$GET(^ACK(509850.9,ACKQIEN,0)))
+5 ;HD63875
IF S0=""
SET ACKQFMD="A"
GOTO S1
+6 ;should be already checked in calling routine
IF $PIECE(S0,U,2)'=DFN
Begin DoDot:1
+7 SET ACKQERR="***URGENT ERROR*** File error - wrong DFN in xref DFN or record: "_DFN
End DoDot:1
GOTO S2
+8 ;DFN name
SET DIC=2
SET DA=DFN
SET DIQ="AK"
SET DR=".01"
DO EN^DIQ1
SET ACKD=AK(2,DFN,.01)
+9 KILL DIC,DA,DIQ,DR,AK
+10 ;(1)=ien^patient^FM date seen^tester
+11 SET ACKDF=$PIECE(^ACK(509850.9,ACKQIEN,0),U,1)
+12 SET ACKQARR(1)=ACKQIEN_U_ACKD_U_ACKDF
+13 IF '$PIECE(S0,U,3)
SET $PIECE(ACKQARR(1),U,4)="Unknown"
+14 IF '$TEST
Begin DoDot:1
+15 SET Y=$PIECE(S0,U,3)
SET X=$$TITLE^ACKQAG01(Y)
KILL Y
+16 ;tester name
SET $PIECE(ACKQARR(1),U,4)=$PIECE(X,U,1)
End DoDot:1
+17 DO GETDATA(ACKQIEN)
END ;if errors, then handle errors and stop
+1 if '$DATA(ACKQARR(1))
SET ACKQARR(1)=0
+2 ;5th pc of 0 node is err msg
IF $GET(ACKQERR)'=""
Begin DoDot:1
+3 FOR I=2:1:25
SET ACKQARR(I)=""
End DoDot:1
DO WRTERR
+4 KILL ACKQERR,ACKQFMD,I,S0
+5 QUIT
+6 ;
GETDATA(ACKQIEN) ;
+1 ;input the entry number in the Audiometic Exam Data file (ACKQIEN)
+2 ;and current return array subscript value(ACKQN)
+3 ;air initial & repeat values, air tags initial & repeat, air Mask Levels
NEW ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L
+4 ;bone initial & repeat values, bone masking init & repeat
NEW ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L
+5 ;P is the piece of the air nodes, P1 is the piece of the bone nodes
NEW P,P1
+6 ;X is the Hz
NEW X
+7 ;counter subscript for array - subsc 1 filled in above
SET ACKQN=1
+8 ;START R ear
+9 ; Air
+10 ;set pcs in ACKQARR node
FOR P=1:1:12
Begin DoDot:1
+11 SET ACKQN=ACKQN+1
+12 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:"")
+13 if X=""
SET X=$SELECT(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")
+14 ;X^ear^ien^Y
SET ACKQARR(ACKQN)=X_U_"R"_U_""
+15 ;init Y val
SET ACKQA1=$PIECE($GET(^ACK(509850.9,ACKQIEN,10)),U,P)
+16 ;init tag
SET ACKQA1T=$PIECE($GET(^ACK(509850.9,ACKQIEN,11)),U,P)
+17 ;init tag level
SET ACKQA1L=$PIECE($GET(^ACK(509850.9,ACKQIEN,50)),U,P)
+18 ;repeat val
SET ACKQA2=$PIECE($GET(^ACK(509850.9,ACKQIEN,20)),U,P)
+19 ;repeat tag
SET ACKQA2T=$PIECE($GET(^ACK(509850.9,ACKQIEN,21)),U,P)
+20 ;repeat tag level
SET ACKQA2L=$PIECE($GET(^ACK(509850.9,ACKQIEN,51)),U,P)
+21 ;default
SET $PIECE(ACKQARR(ACKQN),U,4)=ACKQA1
SET $PIECE(ACKQARR(ACKQN),U,5)=ACKQA1T
+22 SET $PIECE(ACKQARR(ACKQN),U,6)=ACKQA1L
SET $PIECE(ACKQARR(ACKQN),U,12)=ACKQA2
+23 SET $PIECE(ACKQARR(ACKQN),U,13)=ACKQA2T
SET $PIECE(ACKQARR(ACKQN),U,14)=ACKQA2L
+24 ; bone conduction
+25 IF X>125
IF X<7000
Begin DoDot:2
+26 ;125 not a bone reading so pc's 1 less
SET P1=P-1
+27 ;init bone
SET ACKQB1=$PIECE($GET(^ACK(509850.9,ACKQIEN,70)),U,P1)
+28 ;init bone TAG
SET ACKQB1T=$PIECE($GET(^ACK(509850.9,ACKQIEN,71)),U,P1)
+29 ;init bone level
SET ACKQB1L=$PIECE($GET(^ACK(509850.9,ACKQIEN,90)),U,P1)
+30 ;repeat bone
SET ACKQB2=$PIECE($GET(^ACK(509850.9,ACKQIEN,75)),U,P1)
+31 ;repeat bone TAG
SET ACKQB2T=$PIECE($GET(^ACK(509850.9,ACKQIEN,76)),U,P1)
+32 ;repeat bone mask
SET ACKQB2L=$PIECE($GET(^ACK(509850.9,ACKQIEN,91)),U,P1)
+33 SET $PIECE(ACKQARR(ACKQN),U,7)=ACKQB1
SET $PIECE(ACKQARR(ACKQN),U,8)=ACKQB1T
+34 SET $PIECE(ACKQARR(ACKQN),U,9)=ACKQB1L
SET $PIECE(ACKQARR(ACKQN),U,15)=ACKQB2
+35 SET $PIECE(ACKQARR(ACKQN),U,16)=ACKQB2T
SET $PIECE(ACKQARR(ACKQN),U,17)=ACKQB2L
End DoDot:2
+36 ;IAR/CAR AR-DECAY AR-HALFLIFE
+37 IF (X=500)
Begin DoDot:2
+38 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,4)
+39 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,8)
+40 SET $PIECE(ACKQARR(ACKQN),U,18)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,12)
+41 SET $PIECE(ACKQARR(ACKQN),U,19)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,14)
End DoDot:2
+42 IF (X=1000)
Begin DoDot:2
+43 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,5)
+44 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,9)
+45 SET $PIECE(ACKQARR(ACKQN),U,18)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,13)
+46 SET $PIECE(ACKQARR(ACKQN),U,19)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,15)
End DoDot:2
+47 IF (X=2000)
Begin DoDot:2
+48 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,6)
+49 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,10)
End DoDot:2
+50 IF (X=4000)
Begin DoDot:2
+51 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,7)
+52 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,120)),U,11)
End DoDot:2
End DoDot:1
+53 ;start L ear
+54 ; air
+55 FOR P=1:1:12
Begin DoDot:1
+56 ;counter subscript for array
SET ACKQN=ACKQN+1
+57 SET X=$SELECT(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"")
+58 if X=""
SET X=$SELECT(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000)
+59 ; X^ear^IEN^Y
SET ACKQARR(ACKQN)=X_U_"L"_U_""
+60 ;initial read null
SET ACKQA1=$PIECE($GET(^ACK(509850.9,ACKQIEN,30)),U,P)
+61 ;init tag
SET ACKQA1T=$PIECE($GET(^ACK(509850.9,ACKQIEN,31)),U,P)
+62 ;init level
SET ACKQA1L=$PIECE($GET(^ACK(509850.9,ACKQIEN,60)),U,P)
+63 ;repeat val
SET ACKQA2=$PIECE($GET(^ACK(509850.9,ACKQIEN,40)),U,P)
+64 ;repeat tag
SET ACKQA2T=$PIECE($GET(^ACK(509850.9,ACKQIEN,41)),U,P)
+65 ;repeat level
SET ACKQA2L=$PIECE($GET(^ACK(509850.9,ACKQIEN,61)),U,P)
+66 SET $PIECE(ACKQARR(ACKQN),U,4)=ACKQA1
SET $PIECE(ACKQARR(ACKQN),U,5)=ACKQA1T
+67 ; bone conduction
+68 IF X>125
IF X<7000
Begin DoDot:2
+69 ;125 not a bone reading so pc's 1 less
SET P1=P-1
+70 ;init val
SET ACKQB1=$PIECE($GET(^ACK(509850.9,ACKQIEN,80)),U,P1)
+71 ;init tag
SET ACKQB1T=$PIECE($GET(^ACK(509850.9,ACKQIEN,81)),U,P1)
+72 ;init mask level
SET ACKQB1L=$PIECE($GET(^ACK(509850.9,ACKQIEN,100)),U,P1)
+73 ;repeat val
SET ACKQB2=$PIECE($GET(^ACK(509850.9,ACKQIEN,85)),U,P1)
+74 ;repeat tag
SET ACKQB2T=$PIECE($GET(^ACK(509850.9,ACKQIEN,86)),U,P1)
+75 ;repeat mask level
SET ACKQB2L=$PIECE($GET(^ACK(509850.9,ACKQIEN,101)),U,P1)
+76 ;default
SET $PIECE(ACKQARR(ACKQN),U,7)=ACKQB1
SET $PIECE(ACKQARR(ACKQN),U,8)=ACKQB1T
+77 SET $PIECE(ACKQARR(ACKQN),U,9)=ACKQB1L
SET $PIECE(ACKQARR(ACKQN),U,15)=ACKQB2
+78 SET $PIECE(ACKQARR(ACKQN),U,16)=ACKQB2T
SET $PIECE(ACKQARR(ACKQN),U,17)=ACKQB2L
End DoDot:2
+79 ; IAR/CAR AR-DECAY AR-HALFLIFE
+80 IF (X=500)
Begin DoDot:2
+81 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,4)
+82 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,8)
+83 SET $PIECE(ACKQARR(ACKQN),U,18)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,12)
+84 SET $PIECE(ACKQARR(ACKQN),U,19)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,14)
End DoDot:2
+85 IF (X=1000)
Begin DoDot:2
+86 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,5)
+87 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,9)
+88 SET $PIECE(ACKQARR(ACKQN),U,18)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,12)
+89 SET $PIECE(ACKQARR(ACKQN),U,19)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,14)
End DoDot:2
+90 IF (X=2000)
Begin DoDot:2
+91 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,6)
+92 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,10)
End DoDot:2
+93 IF (X=4000)
Begin DoDot:2
+94 SET $PIECE(ACKQARR(ACKQN),U,10)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,7)
+95 SET $PIECE(ACKQARR(ACKQN),U,11)=$PIECE($GET(^ACK(509850.9,ACKQIEN,121)),U,11)
End DoDot:2
End DoDot:1
+96 QUIT
+97 ;
WRTERR ;
+1 IF $LENGTH($GET(ACKQERR))
Begin DoDot:1
+2 ;
SET $PIECE(ACKQARR(1),U,5)=ACKQERR
End DoDot:1
+3 ;W !!,?10,ACKQERR ;used for direct call testing
+4 QUIT
