ACKQAG01 ;DDC/PJU - Get data for Audiogram(s) Display from 509850.9 ;07/13/05
;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
;input: ref to array and DFN. See ACKQAG.txt for information
START(ACKQARR,DFN,IEN) ;;array name(.reference) and pointer to Patient file (#2)
;include IEN in 509850.9 if specific one, otherwise put 0 for last one
; see ACKQAG.txt for descriptions
K ACKQARR ;make sure it starts empty
N ACKT,BD,CL,S0,S1,SSN,TD,TT,TU,J2
S (ACKQARR(0),ACKI,ACKQ)=0
S ACKQERR="" F X=1:1:33 S ACKQARR(X)=""
I '$D(^ACK(509850.9,0)) D G END
.S ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available"
I '$G(DFN) D G END
.S ACKQERR="**ERROR** Must have a DFN for Display "
I '$D(^ACK(509850.9,"DFN",DFN)) D G END
.S ACKQERR="**ERROR** patient not in audiogram file"
D DEM^VADPT ; - demographic variables
I $G(VAERR) S ACKQERR="**ERROR** Problem in retrieving Demographic values" G END
S SSN=$P(VADM(2),U,1),BD=VADM(3)
S ACKQDAT="A",ACKQ1IEN=""
I $G(IEN) D G S3
.S (ACKQ1IEN,ACKQI)=IEN
.S ACKQDAT=$P($G(^ACK(509850.9,IEN,0)),U,1)
.S ACKQ=1
S1 S ACKQDAT=$O(^ACK(509850.9,"DFN",DFN,ACKQDAT),-1) ;get last IEN
I 'ACKQ,'ACKQDAT D G END
.S ACKQERR="**ERROR** No current audiograms for patient in file"
I ACKQ=1,'ACKQDAT G E1 ;only 1
I ACKQ>0 S ACKI=ACKI+1 ;
S ACKQI=0
S2 S ACKQI=$O(^ACK(509850.9,"DFN",DFN,ACKQDAT,ACKQI))
I 'ACKQ,'ACKQI G S1
G:'ACKQI S1
;W !,"Entry number found: ",ACKQI ;for testing
I '$D(^ACK(509850.9,ACKQI,0)) D G END
.S ACKQERR="**ERROR** Node missing in file for this visit"
S ACKQ=ACKQ+1 ;set flag # of Auds
S3 ;
S S0=$G(^ACK(509850.9,ACKQI,0))
I $P(S0,U,2)'=DFN D G END
.S ACKQERR="***URGENT** Actual Patient in Exam File entry:"_ACKQI_" is different than DFN cross-ref, notify IRM"
I ACKQ=1 D G:'$G(IEN) S2 G:$G(IEN) E1
.S ACKQ1IEN=ACKQI,TD=$P(S0,U,1)
.S X=$P($$FMTE^XLFDT(TD),"@",1)
.S ACKQARR(0)=1_U_VADM(1)_U_X ;initial setup
.I $P(S0,U,3) D ;DUZ of tester
..S TU=$P(S0,U,3) D:TU>0
...S TT=$$TITLE(TU)
...S $P(ACKQARR(0),U,4)=$P(TT,U,1) ;tester1 name
...S $P(ACKQARR(0),U,6)=$P(TT,U,2) ;title
.S $P(ACKQARR(0),U,5)=$P(S0,U,5) ;DFN age
.S $P(ACKQARR(0),U,7)=SSN
.S S1=$P(S0,U,10) D:S1
..K AK S DIC=4,DA=S1,DIQ="AK",DR=".01" D EN^DIQ1 ;
..S $P(ACKQARR(33),U,12)=AK(4,S1,.01) ;Sta name
..K AK,DIC,DA,DIQ,DR
.S CL=$P(S0,U,14)
.S $P(ACKQARR(33),U,11)=CL ;claim #
.D GETDATA^ACKQAG06(ACKQI,.ACKI) ;fill air/bone & other nodes
.S ACKT=ACKQ1IEN ;fill (26)
.S S0=$G(^ACK(509850.9,ACKT,120)) ;R AI node
.F X=1:1:15 S $P(ACKQARR(26),U,X)=$P(S0,U,X)
.;PUT R EAR BBNs * IMMIT 678 HERE *****
.S $P(ACKQARR(26),U,31)=$P(S0,U,17) ;R IAR BBN
.S $P(ACKQARR(26),U,32)=$P(S0,U,18) ;R CAR BBN
.S $P(ACKQARR(26),U,33)=$P(S0,U,19) ;R PkIm678
.S S0=$G(^ACK(509850.9,ACKT,121)) ;L AI node
.F X=1:1:15 S $P(ACKQARR(26),U,(X+15))=$P(S0,U,X)
.;PUT L EAR BBNs * IMMIT 678 HERE ***
.S $P(ACKQARR(26),U,34)=$P(S0,U,17) ;L IAR BBN
.S $P(ACKQARR(26),U,35)=$P(S0,U,18) ;L CAR BBN
.S $P(ACKQARR(26),U,36)=$P(S0,U,19) ;L PkIm678
.;Modify (24) 12000 not used in 2364 display or 2364
.S S0=$G(^ACK(509850.9,ACKT,110)),J=4 ;R speech
.F X=6:5:26 D ;6,11,16,21,26
..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) ;pre lev R
..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,(X+1)) ;mask lev R
.S S0=$G(^ACK(509850.9,ACKT,111)) ;L speech
.F X=6:5:26 D ;6,11,16,21,26
..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) ;pre lev L
..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,(X+1)) ;mask lev L
.S S0=$G(^ACK(509850.9,ACKT,1)),J=24
.F X=5,3,1 D ;R AVG'S 4,3,2
..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X)
.F X=6,4,2 D ;L AVG'S 4,3,2
..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X)
.S $P(ACKQARR(33),U,9)=$P(S0,U,11) ;TYMP TYPE R
.S $P(ACKQARR(33),U,10)=$P(S0,U,12) ;TYMP TYPE L
COM .F X=30,31,32 S ACKQARR(X)="" ;COMMENTS LINES
.I $D(^ACK(509850.9,ACKT,122)) S X1="" D
..Q:'$D(^ACK(509850.9,ACKT,122,1,0)) S X1=$G(^(0))
..I $L(X1) D
...S ACKQARR(30)=$E(X1,1,110),X1=$E(X1,111,350)
...S:$L(X1) ACKQARR(31)=$E(X1,1,110)_" ",X1=$E(X1,111,350)
...S:$L(X1) ACKQARR(32)=$E(X1,1,110)_" "
..Q:$L(ACKQARR(32))>105
..Q:'$D(^ACK(509850.9,ACKT,122,2,0)) S X1=$G(^(0))
..I $L(X1) D
...S Z1=$L(ACKQARR(30))
...I Z1<108 S ACKQARR(30)=ACKQARR(30)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
...S Z1=$L(ACKQARR(31)) I Z1<108,$L(X1) D
....S ACKQARR(31)=ACKQARR(31)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
...S Z1=$L(ACKQARR(32)) I $L(X1),Z1<110 D
....S ACKQARR(32)=ACKQARR(32)_$E(X1,1,110-Z1)
..Q:$L(ACKQARR(32))>105
..Q:'$D(^ACK(509850.9,ACKT,122,3,0)) S X1=$G(^(0))
..I $L(X1) D
...S Z1=$L(ACKQARR(30))
...I Z1<108 S ACKQARR(30)=ACKQARR(30)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
...S Z1=$L(ACKQARR(31)) I Z1<108,$L(X1) D
....S ACKQARR(31)=ACKQARR(31)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
...S Z1=$L(ACKQARR(32)) I $L(X1),Z1<108 D
....S ACKQARR(32)=ACKQARR(32)_$E(X1,1,110-Z1)
..Q:$L(ACKQARR(32))>105
..Q:'$D(^ACK(509850.9,ACKT,122,4,0)) S X1=$G(^(0))
..I $L(X1) D
...S Z1=$L(ACKQARR(30))
...I Z1<108 S ACKQARR(30)=ACKQARR(30)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
...S Z1=$L(ACKQARR(31)) I Z1<108,$L(X1) D
....S ACKQARR(31)=ACKQARR(31)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
...S Z1=$L(ACKQARR(32)) I $L(X1),Z1<108 D
....S ACKQARR(32)=ACKQARR(32)_$E(X1,1,110-Z1)
E1 ;for patch 12 add fin readings for display 2364
;sub retest for fin if fin="" for table
S S0=$G(^ACK(509850.9,ACKT,20)) ;fin A test R
S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,75)) ;fin B test R
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,40)) ;fin A test L
F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,85)) ;fin B test L
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
E2 ;for patch 12 add init readings for disp of 2364
S S0=$G(^ACK(509850.9,ACKT,10)) ;1 air test R
S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,70)) ;1 bone test R
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
;
S S0=$G(^ACK(509850.9,ACKT,15)) ;retest A R
S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1 D:(X'="")
.I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for init R A
.E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
.E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,72)) ;retest bone R
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1 D:(X'="")
.I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for init R B
.E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
.E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
S J2=J ;save j for start of L
S S0=$G(^ACK(509850.9,ACKT,30)) ;1st A test L
F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,80)) ;1st B test L
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
S J=J2 ;reset j to start of L ear & sub
S S0=$G(^ACK(509850.9,ACKT,35)) ;retest A L
F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1 D:(X'="")
.I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for 1st L A
.E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
.E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,82)) ;retest B L
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1 D:(X'="")
.I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for 1st L B
.E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
.E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
E3 ;for patch 12 add init tag for disp of 2364
S S0=$G(^ACK(509850.9,ACKT,11)) ;1st A tag R
S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,71)) ;1st B tag R
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,31)) ;1st A tag L
F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,81)) ;1st B tag L
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
E4 ;for patch 12 add final tag for display of 2364
S S0=$G(^ACK(509850.9,ACKT,21)) ;final A tag R
S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,76)) ;final B tag R
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,41)) ;final A tag L
F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
S S0=$G(^ACK(509850.9,ACKT,86)) ;final B tag L
F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
E5 ;for patch 12 add OTHER TESTS score values
S S0=$G(^ACK(509850.9,ACKT,120)) ;Oth Tests R
F P=1:1:4 S $P(ACKQARR(33),U,P)=$P(S0,U,P+19)
S S0=$G(^ACK(509850.9,ACKT,121)) ;Oth Tests L
F P=1:1:4 S $P(ACKQARR(33),U,P+4)=$P(S0,U,P+19)
END ;if 0-1 charts and errors, then kill 1st, & pass error
I $G(ACKQERR)'="",$G(ACKQ)=1 D D WRTERR
.S $P(ACKQARR(0),U,1)=0 F J=3:1:11 S $P(ACKQARR(0),U,J)=""
.F ACKI=1:1:33 S ACKQARR(ACKI)=""
K ACKI,ACKQERR,ACKQDAT,ACKQ,ACKQI,ACKQ1IEN,J,X
Q
WRTERR ; Record error & write out if testing
I $L($G(ACKQERR)) D
.;W !!,?10,ACKQERR ;direct call testing
.S $P(ACKQARR(0),U,8)=ACKQERR ;error for displ in Delphi
Q
TITLE(ACKUSER) ;input DUZ returns printable name and title
N T1,T2,ACK,DIC,DA,DR,DIQ S (T1,T2)="Unknown" G:'$G(ACKUSER) ENDT
S DIC=200,DA=ACKUSER,DIQ="ACK",DR=".01;8" D EN^DIQ1
S T1=$G(ACK(200,ACKUSER,.01))
S T2=$G(ACK(200,ACKUSER,8))
S:T1="" T1="Unknown" S:T2="" T2="Unknown"
ENDT Q T1_U_T2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQAG01 9562 printed Nov 22, 2024@17:41:33 Page 2
ACKQAG01 ;DDC/PJU - Get data for Audiogram(s) Display from 509850.9 ;07/13/05
+1 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
+2 ;input: ref to array and DFN. See ACKQAG.txt for information
START(ACKQARR,DFN,IEN) ;;array name(.reference) and pointer to Patient file (#2)
+1 ;include IEN in 509850.9 if specific one, otherwise put 0 for last one
+2 ; see ACKQAG.txt for descriptions
+3 ;make sure it starts empty
KILL ACKQARR
+4 NEW ACKT,BD,CL,S0,S1,SSN,TD,TT,TU,J2
+5 SET (ACKQARR(0),ACKI,ACKQ)=0
+6 SET ACKQERR=""
FOR X=1:1:33
SET ACKQARR(X)=""
+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 IF '$GET(DFN)
Begin DoDot:1
+10 SET ACKQERR="**ERROR** Must have a DFN for Display "
End DoDot:1
GOTO END
+11 IF '$DATA(^ACK(509850.9,"DFN",DFN))
Begin DoDot:1
+12 SET ACKQERR="**ERROR** patient not in audiogram file"
End DoDot:1
GOTO END
+13 ; - demographic variables
DO DEM^VADPT
+14 IF $GET(VAERR)
SET ACKQERR="**ERROR** Problem in retrieving Demographic values"
GOTO END
+15 SET SSN=$PIECE(VADM(2),U,1)
SET BD=VADM(3)
+16 SET ACKQDAT="A"
SET ACKQ1IEN=""
+17 IF $GET(IEN)
Begin DoDot:1
+18 SET (ACKQ1IEN,ACKQI)=IEN
+19 SET ACKQDAT=$PIECE($GET(^ACK(509850.9,IEN,0)),U,1)
+20 SET ACKQ=1
End DoDot:1
GOTO S3
S1 ;get last IEN
SET ACKQDAT=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQDAT),-1)
+1 IF 'ACKQ
IF 'ACKQDAT
Begin DoDot:1
+2 SET ACKQERR="**ERROR** No current audiograms for patient in file"
End DoDot:1
GOTO END
+3 ;only 1
IF ACKQ=1
IF 'ACKQDAT
GOTO E1
+4 ;
IF ACKQ>0
SET ACKI=ACKI+1
+5 SET ACKQI=0
S2 SET ACKQI=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQDAT,ACKQI))
+1 IF 'ACKQ
IF 'ACKQI
GOTO S1
+2 if 'ACKQI
GOTO S1
+3 ;W !,"Entry number found: ",ACKQI ;for testing
+4 IF '$DATA(^ACK(509850.9,ACKQI,0))
Begin DoDot:1
+5 SET ACKQERR="**ERROR** Node missing in file for this visit"
End DoDot:1
GOTO END
+6 ;set flag # of Auds
SET ACKQ=ACKQ+1
S3 ;
+1 SET S0=$GET(^ACK(509850.9,ACKQI,0))
+2 IF $PIECE(S0,U,2)'=DFN
Begin DoDot:1
+3 SET ACKQERR="***URGENT** Actual Patient in Exam File entry:"_ACKQI_" is different than DFN cross-ref, notify IRM"
End DoDot:1
GOTO END
+4 IF ACKQ=1
Begin DoDot:1
+5 SET ACKQ1IEN=ACKQI
SET TD=$PIECE(S0,U,1)
+6 SET X=$PIECE($$FMTE^XLFDT(TD),"@",1)
+7 ;initial setup
SET ACKQARR(0)=1_U_VADM(1)_U_X
+8 ;DUZ of tester
IF $PIECE(S0,U,3)
Begin DoDot:2
+9 SET TU=$PIECE(S0,U,3)
if TU>0
Begin DoDot:3
+10 SET TT=$$TITLE(TU)
+11 ;tester1 name
SET $PIECE(ACKQARR(0),U,4)=$PIECE(TT,U,1)
+12 ;title
SET $PIECE(ACKQARR(0),U,6)=$PIECE(TT,U,2)
End DoDot:3
End DoDot:2
+13 ;DFN age
SET $PIECE(ACKQARR(0),U,5)=$PIECE(S0,U,5)
+14 SET $PIECE(ACKQARR(0),U,7)=SSN
+15 SET S1=$PIECE(S0,U,10)
if S1
Begin DoDot:2
+16 ;
KILL AK
SET DIC=4
SET DA=S1
SET DIQ="AK"
SET DR=".01"
DO EN^DIQ1
+17 ;Sta name
SET $PIECE(ACKQARR(33),U,12)=AK(4,S1,.01)
+18 KILL AK,DIC,DA,DIQ,DR
End DoDot:2
+19 SET CL=$PIECE(S0,U,14)
+20 ;claim #
SET $PIECE(ACKQARR(33),U,11)=CL
+21 ;fill air/bone & other nodes
DO GETDATA^ACKQAG06(ACKQI,.ACKI)
+22 ;fill (26)
SET ACKT=ACKQ1IEN
+23 ;R AI node
SET S0=$GET(^ACK(509850.9,ACKT,120))
+24 FOR X=1:1:15
SET $PIECE(ACKQARR(26),U,X)=$PIECE(S0,U,X)
+25 ;PUT R EAR BBNs * IMMIT 678 HERE *****
+26 ;R IAR BBN
SET $PIECE(ACKQARR(26),U,31)=$PIECE(S0,U,17)
+27 ;R CAR BBN
SET $PIECE(ACKQARR(26),U,32)=$PIECE(S0,U,18)
+28 ;R PkIm678
SET $PIECE(ACKQARR(26),U,33)=$PIECE(S0,U,19)
+29 ;L AI node
SET S0=$GET(^ACK(509850.9,ACKT,121))
+30 FOR X=1:1:15
SET $PIECE(ACKQARR(26),U,(X+15))=$PIECE(S0,U,X)
+31 ;PUT L EAR BBNs * IMMIT 678 HERE ***
+32 ;L IAR BBN
SET $PIECE(ACKQARR(26),U,34)=$PIECE(S0,U,17)
+33 ;L CAR BBN
SET $PIECE(ACKQARR(26),U,35)=$PIECE(S0,U,18)
+34 ;L PkIm678
SET $PIECE(ACKQARR(26),U,36)=$PIECE(S0,U,19)
+35 ;Modify (24) 12000 not used in 2364 display or 2364
+36 ;R speech
SET S0=$GET(^ACK(509850.9,ACKT,110))
SET J=4
+37 ;6,11,16,21,26
FOR X=6:5:26
Begin DoDot:2
+38 ;pre lev R
SET J=J+1
SET $PIECE(ACKQARR(24),U,J)=$PIECE(S0,U,X)
+39 ;mask lev R
SET J=J+1
SET $PIECE(ACKQARR(24),U,J)=$PIECE(S0,U,(X+1))
End DoDot:2
+40 ;L speech
SET S0=$GET(^ACK(509850.9,ACKT,111))
+41 ;6,11,16,21,26
FOR X=6:5:26
Begin DoDot:2
+42 ;pre lev L
SET J=J+1
SET $PIECE(ACKQARR(24),U,J)=$PIECE(S0,U,X)
+43 ;mask lev L
SET J=J+1
SET $PIECE(ACKQARR(24),U,J)=$PIECE(S0,U,(X+1))
End DoDot:2
+44 SET S0=$GET(^ACK(509850.9,ACKT,1))
SET J=24
+45 ;R AVG'S 4,3,2
FOR X=5,3,1
Begin DoDot:2
+46 SET J=J+1
SET $PIECE(ACKQARR(24),U,J)=$PIECE(S0,U,X)
End DoDot:2
+47 ;L AVG'S 4,3,2
FOR X=6,4,2
Begin DoDot:2
+48 SET J=J+1
SET $PIECE(ACKQARR(24),U,J)=$PIECE(S0,U,X)
End DoDot:2
+49 ;TYMP TYPE R
SET $PIECE(ACKQARR(33),U,9)=$PIECE(S0,U,11)
+50 ;TYMP TYPE L
SET $PIECE(ACKQARR(33),U,10)=$PIECE(S0,U,12)
COM ;COMMENTS LINES
FOR X=30,31,32
SET ACKQARR(X)=""
+1 IF $DATA(^ACK(509850.9,ACKT,122))
SET X1=""
Begin DoDot:2
+2 if '$DATA(^ACK(509850.9,ACKT,122,1,0))
QUIT
SET X1=$GET(^(0))
+3 IF $LENGTH(X1)
Begin DoDot:3
+4 SET ACKQARR(30)=$EXTRACT(X1,1,110)
SET X1=$EXTRACT(X1,111,350)
+5 if $LENGTH(X1)
SET ACKQARR(31)=$EXTRACT(X1,1,110)_" "
SET X1=$EXTRACT(X1,111,350)
+6 if $LENGTH(X1)
SET ACKQARR(32)=$EXTRACT(X1,1,110)_" "
End DoDot:3
+7 if $LENGTH(ACKQARR(32))>105
QUIT
+8 if '$DATA(^ACK(509850.9,ACKT,122,2,0))
QUIT
SET X1=$GET(^(0))
+9 IF $LENGTH(X1)
Begin DoDot:3
+10 SET Z1=$LENGTH(ACKQARR(30))
+11 IF Z1<108
SET ACKQARR(30)=ACKQARR(30)_$EXTRACT(X1,1,110-Z1)_" "
SET X1=$EXTRACT(X1,111-Z1,350)
+12 SET Z1=$LENGTH(ACKQARR(31))
IF Z1<108
IF $LENGTH(X1)
Begin DoDot:4
+13 SET ACKQARR(31)=ACKQARR(31)_$EXTRACT(X1,1,110-Z1)_" "
SET X1=$EXTRACT(X1,111-Z1,350)
End DoDot:4
+14 SET Z1=$LENGTH(ACKQARR(32))
IF $LENGTH(X1)
IF Z1<110
Begin DoDot:4
+15 SET ACKQARR(32)=ACKQARR(32)_$EXTRACT(X1,1,110-Z1)
End DoDot:4
End DoDot:3
+16 if $LENGTH(ACKQARR(32))>105
QUIT
+17 if '$DATA(^ACK(509850.9,ACKT,122,3,0))
QUIT
SET X1=$GET(^(0))
+18 IF $LENGTH(X1)
Begin DoDot:3
+19 SET Z1=$LENGTH(ACKQARR(30))
+20 IF Z1<108
SET ACKQARR(30)=ACKQARR(30)_$EXTRACT(X1,1,110-Z1)_" "
SET X1=$EXTRACT(X1,111-Z1,350)
+21 SET Z1=$LENGTH(ACKQARR(31))
IF Z1<108
IF $LENGTH(X1)
Begin DoDot:4
+22 SET ACKQARR(31)=ACKQARR(31)_$EXTRACT(X1,1,110-Z1)_" "
SET X1=$EXTRACT(X1,111-Z1,350)
End DoDot:4
+23 SET Z1=$LENGTH(ACKQARR(32))
IF $LENGTH(X1)
IF Z1<108
Begin DoDot:4
+24 SET ACKQARR(32)=ACKQARR(32)_$EXTRACT(X1,1,110-Z1)
End DoDot:4
End DoDot:3
+25 if $LENGTH(ACKQARR(32))>105
QUIT
+26 if '$DATA(^ACK(509850.9,ACKT,122,4,0))
QUIT
SET X1=$GET(^(0))
+27 IF $LENGTH(X1)
Begin DoDot:3
+28 SET Z1=$LENGTH(ACKQARR(30))
+29 IF Z1<108
SET ACKQARR(30)=ACKQARR(30)_$EXTRACT(X1,1,110-Z1)_" "
SET X1=$EXTRACT(X1,111-Z1,350)
+30 SET Z1=$LENGTH(ACKQARR(31))
IF Z1<108
IF $LENGTH(X1)
Begin DoDot:4
+31 SET ACKQARR(31)=ACKQARR(31)_$EXTRACT(X1,1,110-Z1)_" "
SET X1=$EXTRACT(X1,111-Z1,350)
End DoDot:4
+32 SET Z1=$LENGTH(ACKQARR(32))
IF $LENGTH(X1)
IF Z1<108
Begin DoDot:4
+33 SET ACKQARR(32)=ACKQARR(32)_$EXTRACT(X1,1,110-Z1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
if '$GET(IEN)
GOTO S2
if $GET(IEN)
GOTO E1
E1 ;for patch 12 add fin readings for display 2364
+1 ;sub retest for fin if fin="" for table
+2 ;fin A test R
SET S0=$GET(^ACK(509850.9,ACKT,20))
+3 SET J=0
FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(12),U,J)=X
+4 ;fin B test R
SET S0=$GET(^ACK(509850.9,ACKT,75))
+5 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(12),U,J)=X
+6 ;fin A test L
SET S0=$GET(^ACK(509850.9,ACKT,40))
+7 FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(12),U,J)=X
+8 ;fin B test L
SET S0=$GET(^ACK(509850.9,ACKT,85))
+9 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(12),U,J)=X
E2 ;for patch 12 add init readings for disp of 2364
+1 ;1 air test R
SET S0=$GET(^ACK(509850.9,ACKT,10))
+2 SET J=0
FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(27),U,J)=X
+3 ;1 bone test R
SET S0=$GET(^ACK(509850.9,ACKT,70))
+4 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(27),U,J)=X
+5 ;
+6 ;retest A R
SET S0=$GET(^ACK(509850.9,ACKT,15))
+7 SET J=0
FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
if (X'="")
Begin DoDot:1
+8 ;sub for init R A
IF $PIECE(ACKQARR(27),U,J)=""
SET $PIECE(ACKQARR(27),U,J)=X
+9 IF '$TEST
IF $PIECE(ACKQARR(27),U,J)["+"
IF X'["+"
SET $PIECE(ACKQARR(27),U,J)=X
+10 IF '$TEST
IF X<$PIECE(ACKQARR(27),U,J)
SET $PIECE(ACKQARR(27),U,J)=X
End DoDot:1
+11 ;retest bone R
SET S0=$GET(^ACK(509850.9,ACKT,72))
+12 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
if (X'="")
Begin DoDot:1
+13 ;sub for init R B
IF $PIECE(ACKQARR(27),U,J)=""
SET $PIECE(ACKQARR(27),U,J)=X
+14 IF '$TEST
IF $PIECE(ACKQARR(27),U,J)["+"
IF X'["+"
SET $PIECE(ACKQARR(27),U,J)=X
+15 IF '$TEST
IF X<$PIECE(ACKQARR(27),U,J)
SET $PIECE(ACKQARR(27),U,J)=X
End DoDot:1
+16 ;save j for start of L
SET J2=J
+17 ;1st A test L
SET S0=$GET(^ACK(509850.9,ACKT,30))
+18 FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(27),U,J)=X
+19 ;1st B test L
SET S0=$GET(^ACK(509850.9,ACKT,80))
+20 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(27),U,J)=X
+21 ;reset j to start of L ear & sub
SET J=J2
+22 ;retest A L
SET S0=$GET(^ACK(509850.9,ACKT,35))
+23 FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
if (X'="")
Begin DoDot:1
+24 ;sub for 1st L A
IF $PIECE(ACKQARR(27),U,J)=""
SET $PIECE(ACKQARR(27),U,J)=X
+25 IF '$TEST
IF $PIECE(ACKQARR(27),U,J)["+"
IF X'["+"
SET $PIECE(ACKQARR(27),U,J)=X
+26 IF '$TEST
IF X<$PIECE(ACKQARR(27),U,J)
SET $PIECE(ACKQARR(27),U,J)=X
End DoDot:1
+27 ;retest B L
SET S0=$GET(^ACK(509850.9,ACKT,82))
+28 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
if (X'="")
Begin DoDot:1
+29 ;sub for 1st L B
IF $PIECE(ACKQARR(27),U,J)=""
SET $PIECE(ACKQARR(27),U,J)=X
+30 IF '$TEST
IF $PIECE(ACKQARR(27),U,J)["+"
IF X'["+"
SET $PIECE(ACKQARR(27),U,J)=X
+31 IF '$TEST
IF X<$PIECE(ACKQARR(27),U,J)
SET $PIECE(ACKQARR(27),U,J)=X
End DoDot:1
E3 ;for patch 12 add init tag for disp of 2364
+1 ;1st A tag R
SET S0=$GET(^ACK(509850.9,ACKT,11))
+2 SET J=0
FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(28),U,J)=X
+3 ;1st B tag R
SET S0=$GET(^ACK(509850.9,ACKT,71))
+4 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(28),U,J)=X
+5 ;1st A tag L
SET S0=$GET(^ACK(509850.9,ACKT,31))
+6 FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(28),U,J)=X
+7 ;1st B tag L
SET S0=$GET(^ACK(509850.9,ACKT,81))
+8 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(28),U,J)=X
E4 ;for patch 12 add final tag for display of 2364
+1 ;final A tag R
SET S0=$GET(^ACK(509850.9,ACKT,21))
+2 SET J=0
FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(29),U,J)=X
+3 ;final B tag R
SET S0=$GET(^ACK(509850.9,ACKT,76))
+4 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(29),U,J)=X
+5 ;final A tag L
SET S0=$GET(^ACK(509850.9,ACKT,41))
+6 FOR P=2,3,5:1:11
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(29),U,J)=X
+7 ;final B tag L
SET S0=$GET(^ACK(509850.9,ACKT,86))
+8 FOR P=1,2,4:1:8
SET X=$PIECE(S0,U,P)
SET J=J+1
SET $PIECE(ACKQARR(29),U,J)=X
E5 ;for patch 12 add OTHER TESTS score values
+1 ;Oth Tests R
SET S0=$GET(^ACK(509850.9,ACKT,120))
+2 FOR P=1:1:4
SET $PIECE(ACKQARR(33),U,P)=$PIECE(S0,U,P+19)
+3 ;Oth Tests L
SET S0=$GET(^ACK(509850.9,ACKT,121))
+4 FOR P=1:1:4
SET $PIECE(ACKQARR(33),U,P+4)=$PIECE(S0,U,P+19)
END ;if 0-1 charts and errors, then kill 1st, & pass error
+1 IF $GET(ACKQERR)'=""
IF $GET(ACKQ)=1
Begin DoDot:1
+2 SET $PIECE(ACKQARR(0),U,1)=0
FOR J=3:1:11
SET $PIECE(ACKQARR(0),U,J)=""
+3 FOR ACKI=1:1:33
SET ACKQARR(ACKI)=""
End DoDot:1
DO WRTERR
+4 KILL ACKI,ACKQERR,ACKQDAT,ACKQ,ACKQI,ACKQ1IEN,J,X
+5 QUIT
WRTERR ; Record error & write out if testing
+1 IF $LENGTH($GET(ACKQERR))
Begin DoDot:1
+2 ;W !!,?10,ACKQERR ;direct call testing
+3 ;error for displ in Delphi
SET $PIECE(ACKQARR(0),U,8)=ACKQERR
End DoDot:1
+4 QUIT
TITLE(ACKUSER) ;input DUZ returns printable name and title
+1 NEW T1,T2,ACK,DIC,DA,DR,DIQ
SET (T1,T2)="Unknown"
if '$GET(ACKUSER)
GOTO ENDT
+2 SET DIC=200
SET DA=ACKUSER
SET DIQ="ACK"
SET DR=".01;8"
DO EN^DIQ1
+3 SET T1=$GET(ACK(200,ACKUSER,.01))
+4 SET T2=$GET(ACK(200,ACKUSER,8))
+5 if T1=""
SET T1="Unknown"
if T2=""
SET T2="Unknown"
ENDT QUIT T1_U_T2
