ACKQAG04 ;DDC/PJU - Utility for ACKQAG03 - Transmission to DDC;5/16/05
;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;4/01/03
;;see descriptions in ACKQAG.TXT
START(ACKQA,DFN) ;
K ACKQE
I '$G(DFN) D G END
.S ACKQE="**ERROR** Must have a DFN to run routine RMPFRPC2 "
I '$D(^ACK(509850.9,0)) D G END
.S ACKQE="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file)"
.S ACKQE=ACKQE_" is not available"
I '$D(^ACK(509850.9,"DFN",DFN)) D G END
.S ACKQE="**ERROR** patient not in audiogram file"
S ACKQDATE="A",ACKQ1IEN=""
S1 S ACKQDATE=$O(^ACK(509850.9,"DFN",DFN,ACKQDATE),-1)
I 'ACKQDATE D G END
.S ACKQE="**ERROR** No current audiograms for patient in file"
S ACKQ1IEN=0
S2 S ACKQ1IEN=$O(^ACK(509850.9,"DFN",DFN,ACKQDATE,ACKQ1IEN))
I 'ACKQ1IEN D G S1
.S ACKQE="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQDATE)
;W !,"Entry number found: ",ACKQ1IEN
I '$D(^ACK(509850.9,ACKQ1IEN,0)) D G S1
.S ACKQE="**ERROR** Node missing in file for this visit"
G EN2
EN(ACKQA,ACKQ1IEN,DFN) ;called from ACKQAG03 for data transmission
EN2 ;entry from S2 to skip EN
K ACKQE N SSN,SD,X,NM,DOB,AGE F I=1:1:35 S ACKQA(I)=""
S ACKQA(1)=0,ACKQN=0
S S0=$G(^ACK(509850.9,ACKQ1IEN,0))
I $P(S0,U,2)'=DFN D G END ;already checked in calling routine
.S ACKQE="***URGENT AUDIOGRAM FILE ERROR*** wrong DFN"
.S ACKQE=ACKQE_" in Cross Reference or record: "_DFN
;Set up ACKQA(1)
S SD=$P(S0,U,1) ;DATE SEEN
S AGE=$P(S0,U,5)
S ACKQA(1)="BGN"_U_ACKQ1IEN
D DEM^VADPT I $G(VAERR) D G END
.S ACKQE="***UNABLE TO ACCESS PATIENT DEMOGRAPHICS***"
D ELIG^VADPT I $G(VAERR) D G END
.S ACKQE="***UNABLE TO ACCESS PATIENT ELIGIBILITY***"
S NM=VADM(1),NM=$E(NM,1,30),SSN=$P(VADM(2),U,1),DOB=$P(VADM(3),U,1)
S $P(ACKQA(1),U,3)=NM
S $P(ACKQA(1),U,4)=SSN ;encrypted in ACKQAG03
;;5th pc is for err msg
S $P(ACKQA(1),U,6)=DOB
I $P(S0,U,3) D ;audiologist
.S Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(Y),X=$E($P(X,U,1),1,30)
.S $P(ACKQA(1),U,7)=X ;title
I '$P(S0,U,3) S $P(ACKQA(1),U,7)="Unknown"
S $P(ACKQA(1),U,8)=$P(S0,U,9) ;dt signed
S $P(ACKQA(1),U,9)=SD ;FM exam dt
S $P(ACKQA(1),U,10)=$S(VAEL(4):"Y",1:"N") ;vet Y/N
S $P(ACKQA(1),U,11)=$P(VAEL(6),U,2) ;DFN Type
S $P(ACKQA(1),U,12)=AGE
S $P(ACKQA(1),U,13)=$P(S0,U,8) ;;transducer type(.08)
S $P(ACKQA(1),U,14)=$P(S0,U,14) ;;claim #(.14)
S $P(ACKQA(1),U,15)=$P(S0,U,15) ;;retrans dt(.15)
D GETDATA(ACKQ1IEN) ;array of test results
END ;
S:'$D(ACKQA(1)) ACKQA(1)=0
I $G(ACKQE)'="" D D WRTERR
.F I=2:1:39 S:$D(ACKQA(I)) ACKQA(I)=""
K ACKQE,ACKQDATE,S0,VADM,VAEL,I
Q
;
GETDATA(ACKQRMI) ;
;;input: entry number in the Audiometic Exam Data file (ACKQRMI)
;;output: set up rest of array ACKQA() subscripts 2-35
N P,P1,S0 ;P is the piece of the A nodes,
;P1 is pc of the B nodes, S0 is a node holder
N X ;X is the Hz
N ACKQN S ACKQN=1 ;counter subscript(ACKQA(1) is filled above)
;subs (2-13) 125-12000 R A & B
F P=1:1:12 D ;START R A
.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 ACKQA(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y
.S $P(ACKQA(ACKQN),U,4)=$P($G(^ACK(509850.9,ACKQRMI,10)),U,P) ;1st Y val
.S $P(ACKQA(ACKQN),U,5)=$P($G(^ACK(509850.9,ACKQRMI,11)),U,P) ;1st tag(send anyway)
.S $P(ACKQA(ACKQN),U,6)=$P($G(^ACK(509850.9,ACKQRMI,50)),U,P) ;1st mask level
.S $P(ACKQA(ACKQN),U,12)=$P($G(^ACK(509850.9,ACKQRMI,20)),U,P) ;final val
.S $P(ACKQA(ACKQN),U,13)=$P($G(^ACK(509850.9,ACKQRMI,21)),U,P) ;final tag(send anyway)
.S $P(ACKQA(ACKQN),U,14)=$P($G(^ACK(509850.9,ACKQRMI,51)),U,P) ;final mask lev
.;R B
.I X>125,X<7000 D
..S P1=P-1 ;125 not B reading so pc's 1 less
..S $P(ACKQA(ACKQN),U,7)=$P($G(^ACK(509850.9,ACKQRMI,70)),U,P1) ;1st B
..;S $P(ACKQA(ACKQN),U,8)=$P($G(^ACK(509850.9,ACKQRMI,71)),U,P1) ;1st bTAG(send anyway)
..S $P(ACKQA(ACKQN),U,9)=$P($G(^ACK(509850.9,ACKQRMI,90)),U,P1) ;1st mask level
..S $P(ACKQA(ACKQN),U,15)=$P($G(^ACK(509850.9,ACKQRMI,75)),U,P1) ;final B
..;S $P(ACKQA(ACKQN),U,16)=$P($G(^ACK(509850.9,ACKQRMI,76)),U,P1) ;f bTAG(send anyway)
..S $P(ACKQA(ACKQN),U,17)=$P($G(^ACK(509850.9,ACKQRMI,91)),U,P1) ;f B mask
.;IAR/CAR AR-DECAY AR-HALFLIFE
.S S0=$G(^ACK(509850.9,ACKQRMI,120))
.I (X=500) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,4) ;R IAR 500
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,8) ;R CAR 500
..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,12) ;R AR decay 500
..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,14) ;R AR HL 500
.I (X=1000) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,5) ;R IAR 1000
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,9) ;R CAR 1000
..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,13) ;R AR decay 1000
..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,15) ;R AR HL 1000
.I (X=2000) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,6) ;R IAR 2000
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,10) ;R CAR 2000
.I (X=4000) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,7) ;R IAR 4000
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,11) ;R CAR 4000
;;subs (14-25) 125-12000 L A&B
F P=1:1:12 D ;start L A
.S ACKQN=ACKQN+1 ;counter sub 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 ACKQA(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y
.S $P(ACKQA(ACKQN),U,4)=$P($G(^ACK(509850.9,ACKQRMI,30)),U,P) ;1st value
.S $P(ACKQA(ACKQN),U,5)=$P($G(^ACK(509850.9,ACKQRMI,31)),U,P) ;1st tag(lv for now)
.S $P(ACKQA(ACKQN),U,6)=$P($G(^ACK(509850.9,ACKQRMI,60)),U,P) ;1st mlev
.S $P(ACKQA(ACKQN),U,12)=$P($G(^ACK(509850.9,ACKQRMI,40)),U,P) ;final val
.S $P(ACKQA(ACKQN),U,13)=$P($G(^ACK(509850.9,ACKQRMI,41)),U,P) ;f tag(lv for now)
.S $P(ACKQA(ACKQN),U,14)=$P($G(^ACK(509850.9,ACKQRMI,61)),U,P) ;f mlev
.;L ear bone conduction
.I X>125,X<7000 D
..S P1=P-1 ;125 not a bone reading so pc's 1 less
..S $P(ACKQA(ACKQN),U,7)=$P($G(^ACK(509850.9,ACKQRMI,80)),U,P1) ;1st val
..S $P(ACKQA(ACKQN),U,8)=$P($G(^ACK(509850.9,ACKQRMI,81)),U,P1) ;1st tag(lv for now)
..S $P(ACKQA(ACKQN),U,9)=$P($G(^ACK(509850.9,ACKQRMI,100)),U,P1) ;1st mlev
..S $P(ACKQA(ACKQN),U,15)=$P($G(^ACK(509850.9,ACKQRMI,85)),U,P1) ;final val
..S $P(ACKQA(ACKQN),U,16)=$P($G(^ACK(509850.9,ACKQRMI,86)),U,P1) ;f tag(lv for now)
..S $P(ACKQA(ACKQN),U,17)=$P($G(^ACK(509850.9,ACKQRMI,101)),U,P1) ;f mlev
.; IAR/CAR AR-DECAY AR-HL
.S S0=$G(^ACK(509850.9,ACKQRMI,121))
.I (X=500) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,4) ;L IAR 500
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,8) ;L CAR 500
..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,12) ;L AR decay 500
..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,14) ;L AR HL 500
.I (X=1000) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,5) ;L IAR 1000
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,9) ;L CAR 1000
..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,13) ;L AR decay 1000
..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,15) ;L AR HL 1000
.I (X=2000) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,6) ;L IAR 2000
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,10) ;L CAR 2000
.I (X=4000) D
..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,7) ;L IAR 4000
..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,11) ;L CAR 4000
S ACKQN=ACKQN+1 ;sub(26) R Sp
S ACKQA(ACKQN)="WDL^R^"_$G(^ACK(509850.9,ACKQRMI,110))
S ACKQN=ACKQN+1 ;subscript(27) L Sp
S ACKQA(ACKQN)="WDL^L^"_$G(^ACK(509850.9,ACKQRMI,111))
S $P(ACKQA(ACKQN),U,1)="WDL",$P(ACKQA(ACKQN),U,2)="L"
S ACKQN=ACKQN+1 ;sub(28) R&L PTA,MCL,UCL,tymp type
S ACKQA(ACKQN)="PTA^B^"_$G(^ACK(509850.9,ACKQRMI,1))
S S0=$G(^ACK(509850.9,ACKQRMI,120)) D ;add 3 pcs to (28)
.S $P(ACKQA(ACKQN),U,15)=$P(S0,U,1) ;middle ear pres R
.S $P(ACKQA(ACKQN),U,16)=$P(S0,U,2) ;pk immit 226 R
.S $P(ACKQA(ACKQN),U,17)=$P(S0,U,16) ;int test consis R
S S0=$G(^ACK(509850.9,ACKQRMI,121)) D ;add 3 more pcs to (28)
.S $P(ACKQA(ACKQN),U,18)=$P(S0,U,1) ;middle ear pres L
.S $P(ACKQA(ACKQN),U,19)=$P(S0,U,2) ;pk immit 226 L
.S $P(ACKQA(ACKQN),U,20)=$P(S0,U,16) ;int tst consis L
S ACKQN=ACKQN+1 ;sub(29) R&L SRT,PIPB
S ACKQA(ACKQN)="SRT^B^"_$G(^ACK(509850.9,ACKQRMI,115)) ;16+2 pcs
S ACKQN=ACKQN+1 ;sub(30) R A retest
S ACKQA(ACKQN)="RTSTR^R^"_$G(^ACK(509850.9,ACKQRMI,15)) ;11+2 pcs
S ACKQN=ACKQN+1 ;sub(31) L A retest
S ACKQA(ACKQN)="RTSTL^L^"_$G(^ACK(509850.9,ACKQRMI,35)) ;11+2 pcs
S ACKQN=ACKQN+1 ;sub(32) R B retest
S ACKQA(ACKQN)="RTSTRB^R^"_$G(^ACK(509850.9,ACKQRMI,72)) ;9+2 pcs
S ACKQN=ACKQN+1 ;sub(33) L B retest
S ACKQA(ACKQN)="RTSTLB^L^"_$G(^ACK(509850.9,ACKQRMI,82)) ;9+2 pcs
S ACKQN=ACKQN+1 ;sub(34) R AI & word node
S ACKQA(ACKQN)="RAI^R^"_$G(^ACK(509850.9,ACKQRMI,120)) ;23+2 pcs
S ACKQN=ACKQN+1 ;sub(35) L AI & word node
S ACKQA(ACKQN)="LAI^L^"_$G(^ACK(509850.9,ACKQRMI,121)) ;23+2 pcs
D COMMTS
Q
WRTERR ;
I $L($G(ACKQE)) D
.S $P(ACKQA(1),U,5)=ACKQE
Q
COMMTS ;add comments to transmit
;INPUT ACKQRMI,ACKQN
Q:'$D(^ACK(509850.9,ACKQRMI,122)) Q:'$O(^ACK(509850.9,ACKQRMI,122,0))
N C,X S C=0
C1 S C=$O(^ACK(509850.9,ACKQRMI,122,C)) Q:'C D
.S ACKQN=ACKQN+1,X=$G(^ACK(509850.9,ACKQRMI,122,C,0))
.S X=$TR(X,"^","")
.S ACKQA(ACKQN)="COM^"_C_U_X
G C1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQAG04 9053 printed Dec 13, 2024@02:31:35 Page 2
ACKQAG04 ;DDC/PJU - Utility for ACKQAG03 - Transmission to DDC;5/16/05
+1 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;4/01/03
+2 ;;see descriptions in ACKQAG.TXT
START(ACKQA,DFN) ;
+1 KILL ACKQE
+2 IF '$GET(DFN)
Begin DoDot:1
+3 SET ACKQE="**ERROR** Must have a DFN to run routine RMPFRPC2 "
End DoDot:1
GOTO END
+4 IF '$DATA(^ACK(509850.9,0))
Begin DoDot:1
+5 SET ACKQE="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file)"
+6 SET ACKQE=ACKQE_" is not available"
End DoDot:1
GOTO END
+7 IF '$DATA(^ACK(509850.9,"DFN",DFN))
Begin DoDot:1
+8 SET ACKQE="**ERROR** patient not in audiogram file"
End DoDot:1
GOTO END
+9 SET ACKQDATE="A"
SET ACKQ1IEN=""
S1 SET ACKQDATE=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQDATE),-1)
+1 IF 'ACKQDATE
Begin DoDot:1
+2 SET ACKQE="**ERROR** No current audiograms for patient in file"
End DoDot:1
GOTO END
+3 SET ACKQ1IEN=0
S2 SET ACKQ1IEN=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQDATE,ACKQ1IEN))
+1 IF 'ACKQ1IEN
Begin DoDot:1
+2 SET ACKQE="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQDATE)
End DoDot:1
GOTO S1
+3 ;W !,"Entry number found: ",ACKQ1IEN
+4 IF '$DATA(^ACK(509850.9,ACKQ1IEN,0))
Begin DoDot:1
+5 SET ACKQE="**ERROR** Node missing in file for this visit"
End DoDot:1
GOTO S1
+6 GOTO EN2
EN(ACKQA,ACKQ1IEN,DFN) ;called from ACKQAG03 for data transmission
EN2 ;entry from S2 to skip EN
+1 KILL ACKQE
NEW SSN,SD,X,NM,DOB,AGE
FOR I=1:1:35
SET ACKQA(I)=""
+2 SET ACKQA(1)=0
SET ACKQN=0
+3 SET S0=$GET(^ACK(509850.9,ACKQ1IEN,0))
+4 ;already checked in calling routine
IF $PIECE(S0,U,2)'=DFN
Begin DoDot:1
+5 SET ACKQE="***URGENT AUDIOGRAM FILE ERROR*** wrong DFN"
+6 SET ACKQE=ACKQE_" in Cross Reference or record: "_DFN
End DoDot:1
GOTO END
+7 ;Set up ACKQA(1)
+8 ;DATE SEEN
SET SD=$PIECE(S0,U,1)
+9 SET AGE=$PIECE(S0,U,5)
+10 SET ACKQA(1)="BGN"_U_ACKQ1IEN
+11 DO DEM^VADPT
IF $GET(VAERR)
Begin DoDot:1
+12 SET ACKQE="***UNABLE TO ACCESS PATIENT DEMOGRAPHICS***"
End DoDot:1
GOTO END
+13 DO ELIG^VADPT
IF $GET(VAERR)
Begin DoDot:1
+14 SET ACKQE="***UNABLE TO ACCESS PATIENT ELIGIBILITY***"
End DoDot:1
GOTO END
+15 SET NM=VADM(1)
SET NM=$EXTRACT(NM,1,30)
SET SSN=$PIECE(VADM(2),U,1)
SET DOB=$PIECE(VADM(3),U,1)
+16 SET $PIECE(ACKQA(1),U,3)=NM
+17 ;encrypted in ACKQAG03
SET $PIECE(ACKQA(1),U,4)=SSN
+18 ;;5th pc is for err msg
+19 SET $PIECE(ACKQA(1),U,6)=DOB
+20 ;audiologist
IF $PIECE(S0,U,3)
Begin DoDot:1
+21 SET Y=$PIECE(S0,U,3)
SET X=$$TITLE^ACKQAG01(Y)
SET X=$EXTRACT($PIECE(X,U,1),1,30)
+22 ;title
SET $PIECE(ACKQA(1),U,7)=X
End DoDot:1
+23 IF '$PIECE(S0,U,3)
SET $PIECE(ACKQA(1),U,7)="Unknown"
+24 ;dt signed
SET $PIECE(ACKQA(1),U,8)=$PIECE(S0,U,9)
+25 ;FM exam dt
SET $PIECE(ACKQA(1),U,9)=SD
+26 ;vet Y/N
SET $PIECE(ACKQA(1),U,10)=$SELECT(VAEL(4):"Y",1:"N")
+27 ;DFN Type
SET $PIECE(ACKQA(1),U,11)=$PIECE(VAEL(6),U,2)
+28 SET $PIECE(ACKQA(1),U,12)=AGE
+29 ;;transducer type(.08)
SET $PIECE(ACKQA(1),U,13)=$PIECE(S0,U,8)
+30 ;;claim #(.14)
SET $PIECE(ACKQA(1),U,14)=$PIECE(S0,U,14)
+31 ;;retrans dt(.15)
SET $PIECE(ACKQA(1),U,15)=$PIECE(S0,U,15)
+32 ;array of test results
DO GETDATA(ACKQ1IEN)
END ;
+1 if '$DATA(ACKQA(1))
SET ACKQA(1)=0
+2 IF $GET(ACKQE)'=""
Begin DoDot:1
+3 FOR I=2:1:39
if $DATA(ACKQA(I))
SET ACKQA(I)=""
End DoDot:1
DO WRTERR
+4 KILL ACKQE,ACKQDATE,S0,VADM,VAEL,I
+5 QUIT
+6 ;
GETDATA(ACKQRMI) ;
+1 ;;input: entry number in the Audiometic Exam Data file (ACKQRMI)
+2 ;;output: set up rest of array ACKQA() subscripts 2-35
+3 ;P is the piece of the A nodes,
NEW P,P1,S0
+4 ;P1 is pc of the B nodes, S0 is a node holder
+5 ;X is the Hz
NEW X
+6 ;counter subscript(ACKQA(1) is filled above)
NEW ACKQN
SET ACKQN=1
+7 ;subs (2-13) 125-12000 R A & B
+8 ;START R A
FOR P=1:1:12
Begin DoDot:1
+9 SET ACKQN=ACKQN+1
+10 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:"")
+11 if X=""
SET X=$SELECT(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")
+12 ;X^ear^ien^Y
SET ACKQA(ACKQN)=X_U_"R"_U_""
+13 ;1st Y val
SET $PIECE(ACKQA(ACKQN),U,4)=$PIECE($GET(^ACK(509850.9,ACKQRMI,10)),U,P)
+14 ;1st tag(send anyway)
SET $PIECE(ACKQA(ACKQN),U,5)=$PIECE($GET(^ACK(509850.9,ACKQRMI,11)),U,P)
+15 ;1st mask level
SET $PIECE(ACKQA(ACKQN),U,6)=$PIECE($GET(^ACK(509850.9,ACKQRMI,50)),U,P)
+16 ;final val
SET $PIECE(ACKQA(ACKQN),U,12)=$PIECE($GET(^ACK(509850.9,ACKQRMI,20)),U,P)
+17 ;final tag(send anyway)
SET $PIECE(ACKQA(ACKQN),U,13)=$PIECE($GET(^ACK(509850.9,ACKQRMI,21)),U,P)
+18 ;final mask lev
SET $PIECE(ACKQA(ACKQN),U,14)=$PIECE($GET(^ACK(509850.9,ACKQRMI,51)),U,P)
+19 ;R B
+20 IF X>125
IF X<7000
Begin DoDot:2
+21 ;125 not B reading so pc's 1 less
SET P1=P-1
+22 ;1st B
SET $PIECE(ACKQA(ACKQN),U,7)=$PIECE($GET(^ACK(509850.9,ACKQRMI,70)),U,P1)
+23 ;S $P(ACKQA(ACKQN),U,8)=$P($G(^ACK(509850.9,ACKQRMI,71)),U,P1) ;1st bTAG(send anyway)
+24 ;1st mask level
SET $PIECE(ACKQA(ACKQN),U,9)=$PIECE($GET(^ACK(509850.9,ACKQRMI,90)),U,P1)
+25 ;final B
SET $PIECE(ACKQA(ACKQN),U,15)=$PIECE($GET(^ACK(509850.9,ACKQRMI,75)),U,P1)
+26 ;S $P(ACKQA(ACKQN),U,16)=$P($G(^ACK(509850.9,ACKQRMI,76)),U,P1) ;f bTAG(send anyway)
+27 ;f B mask
SET $PIECE(ACKQA(ACKQN),U,17)=$PIECE($GET(^ACK(509850.9,ACKQRMI,91)),U,P1)
End DoDot:2
+28 ;IAR/CAR AR-DECAY AR-HALFLIFE
+29 SET S0=$GET(^ACK(509850.9,ACKQRMI,120))
+30 IF (X=500)
Begin DoDot:2
+31 ;R IAR 500
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,4)
+32 ;R CAR 500
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,8)
+33 ;R AR decay 500
SET $PIECE(ACKQA(ACKQN),U,18)=$PIECE(S0,U,12)
+34 ;R AR HL 500
SET $PIECE(ACKQA(ACKQN),U,19)=$PIECE(S0,U,14)
End DoDot:2
+35 IF (X=1000)
Begin DoDot:2
+36 ;R IAR 1000
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,5)
+37 ;R CAR 1000
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,9)
+38 ;R AR decay 1000
SET $PIECE(ACKQA(ACKQN),U,18)=$PIECE(S0,U,13)
+39 ;R AR HL 1000
SET $PIECE(ACKQA(ACKQN),U,19)=$PIECE(S0,U,15)
End DoDot:2
+40 IF (X=2000)
Begin DoDot:2
+41 ;R IAR 2000
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,6)
+42 ;R CAR 2000
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,10)
End DoDot:2
+43 IF (X=4000)
Begin DoDot:2
+44 ;R IAR 4000
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,7)
+45 ;R CAR 4000
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,11)
End DoDot:2
End DoDot:1
+46 ;;subs (14-25) 125-12000 L A&B
+47 ;start L A
FOR P=1:1:12
Begin DoDot:1
+48 ;counter sub for array
SET ACKQN=ACKQN+1
+49 SET X=$SELECT(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"")
+50 if X=""
SET X=$SELECT(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000)
+51 ; X^ear^IEN^Y
SET ACKQA(ACKQN)=X_U_"L"_U_""
+52 ;1st value
SET $PIECE(ACKQA(ACKQN),U,4)=$PIECE($GET(^ACK(509850.9,ACKQRMI,30)),U,P)
+53 ;1st tag(lv for now)
SET $PIECE(ACKQA(ACKQN),U,5)=$PIECE($GET(^ACK(509850.9,ACKQRMI,31)),U,P)
+54 ;1st mlev
SET $PIECE(ACKQA(ACKQN),U,6)=$PIECE($GET(^ACK(509850.9,ACKQRMI,60)),U,P)
+55 ;final val
SET $PIECE(ACKQA(ACKQN),U,12)=$PIECE($GET(^ACK(509850.9,ACKQRMI,40)),U,P)
+56 ;f tag(lv for now)
SET $PIECE(ACKQA(ACKQN),U,13)=$PIECE($GET(^ACK(509850.9,ACKQRMI,41)),U,P)
+57 ;f mlev
SET $PIECE(ACKQA(ACKQN),U,14)=$PIECE($GET(^ACK(509850.9,ACKQRMI,61)),U,P)
+58 ;L ear bone conduction
+59 IF X>125
IF X<7000
Begin DoDot:2
+60 ;125 not a bone reading so pc's 1 less
SET P1=P-1
+61 ;1st val
SET $PIECE(ACKQA(ACKQN),U,7)=$PIECE($GET(^ACK(509850.9,ACKQRMI,80)),U,P1)
+62 ;1st tag(lv for now)
SET $PIECE(ACKQA(ACKQN),U,8)=$PIECE($GET(^ACK(509850.9,ACKQRMI,81)),U,P1)
+63 ;1st mlev
SET $PIECE(ACKQA(ACKQN),U,9)=$PIECE($GET(^ACK(509850.9,ACKQRMI,100)),U,P1)
+64 ;final val
SET $PIECE(ACKQA(ACKQN),U,15)=$PIECE($GET(^ACK(509850.9,ACKQRMI,85)),U,P1)
+65 ;f tag(lv for now)
SET $PIECE(ACKQA(ACKQN),U,16)=$PIECE($GET(^ACK(509850.9,ACKQRMI,86)),U,P1)
+66 ;f mlev
SET $PIECE(ACKQA(ACKQN),U,17)=$PIECE($GET(^ACK(509850.9,ACKQRMI,101)),U,P1)
End DoDot:2
+67 ; IAR/CAR AR-DECAY AR-HL
+68 SET S0=$GET(^ACK(509850.9,ACKQRMI,121))
+69 IF (X=500)
Begin DoDot:2
+70 ;L IAR 500
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,4)
+71 ;L CAR 500
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,8)
+72 ;L AR decay 500
SET $PIECE(ACKQA(ACKQN),U,18)=$PIECE(S0,U,12)
+73 ;L AR HL 500
SET $PIECE(ACKQA(ACKQN),U,19)=$PIECE(S0,U,14)
End DoDot:2
+74 IF (X=1000)
Begin DoDot:2
+75 ;L IAR 1000
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,5)
+76 ;L CAR 1000
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,9)
+77 ;L AR decay 1000
SET $PIECE(ACKQA(ACKQN),U,18)=$PIECE(S0,U,13)
+78 ;L AR HL 1000
SET $PIECE(ACKQA(ACKQN),U,19)=$PIECE(S0,U,15)
End DoDot:2
+79 IF (X=2000)
Begin DoDot:2
+80 ;L IAR 2000
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,6)
+81 ;L CAR 2000
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,10)
End DoDot:2
+82 IF (X=4000)
Begin DoDot:2
+83 ;L IAR 4000
SET $PIECE(ACKQA(ACKQN),U,10)=$PIECE(S0,U,7)
+84 ;L CAR 4000
SET $PIECE(ACKQA(ACKQN),U,11)=$PIECE(S0,U,11)
End DoDot:2
End DoDot:1
+85 ;sub(26) R Sp
SET ACKQN=ACKQN+1
+86 SET ACKQA(ACKQN)="WDL^R^"_$GET(^ACK(509850.9,ACKQRMI,110))
+87 ;subscript(27) L Sp
SET ACKQN=ACKQN+1
+88 SET ACKQA(ACKQN)="WDL^L^"_$GET(^ACK(509850.9,ACKQRMI,111))
+89 SET $PIECE(ACKQA(ACKQN),U,1)="WDL"
SET $PIECE(ACKQA(ACKQN),U,2)="L"
+90 ;sub(28) R&L PTA,MCL,UCL,tymp type
SET ACKQN=ACKQN+1
+91 SET ACKQA(ACKQN)="PTA^B^"_$GET(^ACK(509850.9,ACKQRMI,1))
+92 ;add 3 pcs to (28)
SET S0=$GET(^ACK(509850.9,ACKQRMI,120))
Begin DoDot:1
+93 ;middle ear pres R
SET $PIECE(ACKQA(ACKQN),U,15)=$PIECE(S0,U,1)
+94 ;pk immit 226 R
SET $PIECE(ACKQA(ACKQN),U,16)=$PIECE(S0,U,2)
+95 ;int test consis R
SET $PIECE(ACKQA(ACKQN),U,17)=$PIECE(S0,U,16)
End DoDot:1
+96 ;add 3 more pcs to (28)
SET S0=$GET(^ACK(509850.9,ACKQRMI,121))
Begin DoDot:1
+97 ;middle ear pres L
SET $PIECE(ACKQA(ACKQN),U,18)=$PIECE(S0,U,1)
+98 ;pk immit 226 L
SET $PIECE(ACKQA(ACKQN),U,19)=$PIECE(S0,U,2)
+99 ;int tst consis L
SET $PIECE(ACKQA(ACKQN),U,20)=$PIECE(S0,U,16)
End DoDot:1
+100 ;sub(29) R&L SRT,PIPB
SET ACKQN=ACKQN+1
+101 ;16+2 pcs
SET ACKQA(ACKQN)="SRT^B^"_$GET(^ACK(509850.9,ACKQRMI,115))
+102 ;sub(30) R A retest
SET ACKQN=ACKQN+1
+103 ;11+2 pcs
SET ACKQA(ACKQN)="RTSTR^R^"_$GET(^ACK(509850.9,ACKQRMI,15))
+104 ;sub(31) L A retest
SET ACKQN=ACKQN+1
+105 ;11+2 pcs
SET ACKQA(ACKQN)="RTSTL^L^"_$GET(^ACK(509850.9,ACKQRMI,35))
+106 ;sub(32) R B retest
SET ACKQN=ACKQN+1
+107 ;9+2 pcs
SET ACKQA(ACKQN)="RTSTRB^R^"_$GET(^ACK(509850.9,ACKQRMI,72))
+108 ;sub(33) L B retest
SET ACKQN=ACKQN+1
+109 ;9+2 pcs
SET ACKQA(ACKQN)="RTSTLB^L^"_$GET(^ACK(509850.9,ACKQRMI,82))
+110 ;sub(34) R AI & word node
SET ACKQN=ACKQN+1
+111 ;23+2 pcs
SET ACKQA(ACKQN)="RAI^R^"_$GET(^ACK(509850.9,ACKQRMI,120))
+112 ;sub(35) L AI & word node
SET ACKQN=ACKQN+1
+113 ;23+2 pcs
SET ACKQA(ACKQN)="LAI^L^"_$GET(^ACK(509850.9,ACKQRMI,121))
+114 DO COMMTS
+115 QUIT
WRTERR ;
+1 IF $LENGTH($GET(ACKQE))
Begin DoDot:1
+2 SET $PIECE(ACKQA(1),U,5)=ACKQE
End DoDot:1
+3 QUIT
COMMTS ;add comments to transmit
+1 ;INPUT ACKQRMI,ACKQN
+2 if '$DATA(^ACK(509850.9,ACKQRMI,122))
QUIT
if '$ORDER(^ACK(509850.9,ACKQRMI,122,0))
QUIT
+3 NEW C,X
SET C=0
C1 SET C=$ORDER(^ACK(509850.9,ACKQRMI,122,C))
if 'C
QUIT
Begin DoDot:1
+1 SET ACKQN=ACKQN+1
SET X=$GET(^ACK(509850.9,ACKQRMI,122,C,0))
+2 SET X=$TRANSLATE(X,"^","")
+3 SET ACKQA(ACKQN)="COM^"_C_U_X
End DoDot:1
+4 GOTO C1
