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)   ;
 
ACKQERR
 
;ACKQN is a number counter, S0 is a node holder
 ;ACKQERR is an error holder
 ;ACKQFMD hold dates, ACKQ1IEN  holds the entry number
 
'$G(DFND  G END
 
.ACKQERR="**ERROR** Must have a DFN to run routine RMPFRPC2 "
 
'$D(^ACK(509850.9,0)) D  G END
 
.ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available"
 ;look up DFN in file
 
'$D(^ACK(509850.9,"DFN",DFN)) D  G END
 
.ACKQERR="**ERROR** patient not in audiogram file"
 ;determine if 1 or 2 audiograms - set flag
 
ACKQFMD="A",ACKQ1IEN=""
S1 ACKQFMD=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD),-1)
 
;set up array for latest one in file
 
'ACKQFMD D  G END
 
.ACKQERR="**ERROR** No current audiograms for patient in file"
 
ACKQIEN=0
S2 ACKQIEN=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD,ACKQIEN))
 
'ACKQIEN D  G S1
 
.ACKQERR="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQFMD)
 
'$D(^ACK(509850.9,ACKQIEN,0)) D  G S1
 
.ACKQERR="**ERROR** Node missing in file for this visit"
 
EN2 ;to skip following line
EN(ACKQARR,ACKQIEN,DFN) ;
EN2 ;from S2
 
ACK,ACKD,ACKDF,ACKT
 
ACKQARR(1)=0 ;default
 
ACKQERR I=2:1:25 ACKQARR(I)=""
 
S0=$S(ACKQIEN="":"",1:$G(^ACK(509850.9,ACKQIEN,0))) ;HD63875
 
S0="" ACKQFMD="A" S1 ;HD63875
 
I $P(S0,U,2)'=DFN D  G S2 ;should be already checked in calling routine
 
.ACKQERR="***URGENT ERROR*** File error - wrong DFN in xref DFN or record: "_DFN
 
DIC=2,DA=DFN,DIQ="AK",DR=".01" EN^DIQ1 ACKD=AK(2,DFN,.01) ;DFN name
 
DIC,DA,DIQ,DR,AK
 
;(1)=ien^patient^FM date seen^tester
 
ACKDF=$P(^ACK(509850.9,ACKQIEN,0),U,1)
 
ACKQARR(1)=ACKQIEN_U_ACKD_U_ACKDF
 
'$P(S0,U,3) S $P(ACKQARR(1),U,4)="Unknown"
 
E  D
 
.Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(YY
 
.S $P(ACKQARR(1),U,4)=$P(X,U,1) ;tester name
 
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
 
.I=2:1:25 ACKQARR(I)=""
 
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)
 
ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L ;air initial & repeat values, air tags initial & repeat, air Mask Levels
 
ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L ;bone initial & repeat values, bone masking init & repeat
 
P,P1 ;P is the piece of the air nodes, P1 is the piece of the bone nodes
 
;X is the Hz
 
ACKQN=1 ;counter subscript for array - subsc 1 filled in above
 ;START R ear
 ; Air
 
P=1:1:12 D  ;set pcs in ACKQARR node
 
.ACKQN=ACKQN+1
 .
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:"")
 .
ACKQARR(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y
 
.ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,10)),U,P;init Y val
 
.ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,11)),U,P;init tag
 
.ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,50)),U,P;init tag level
 
.ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,20)),U,P;repeat val
 
.ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,21)),U,P;repeat tag
 
.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
 
.X>125,X<7000 D
 
..P1=P-1 ;125 not a bone reading so pc's 1 less
 
..ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,70)),U,P1;init bone
 
..ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,71)),U,P1;init bone TAG
 
..ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,90)),U,P1;init bone level
 
..ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,75)),U,P1;repeat bone
 
..ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,76)),U,P1;repeat bone TAG
 
..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
 
.(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)
 .
(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)
 .
(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)
 .
(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
 
P=1:1:12 D
 
.ACKQN=ACKQN+1 ;counter subscript for array
 
.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)
 .
ACKQARR(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y
 
.ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,30)),U,P;initial read null
 
.ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,31)),U,P;init tag
 
.ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,60)),U,P;init level
 
.ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,40)),U,P;repeat val
 
.ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,41)),U,P;repeat tag
 
.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
 
.X>125,X<7000 D
 
..P1=P-1 ;125 not a bone reading so pc's 1 less
 
..ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,80)),U,P1;init val
 
..ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,81)),U,P1;init tag
 
..ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,100)),U,P1;init mask level
 
..ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,85)),U,P1;repeat val
 
..ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,86)),U,P1;repeat tag
 
..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
 
.(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)
 .
(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)
 .
(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)
 .
(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