YTQRRPT ;SLC/LLH - Report Builder ; 08/13/2018
;;5.01;MENTAL HEALTH;**130,141,172,218**;Dec 30, 1994;Build 9
;
; Reference to DIQ in ICR #2056
; Reference to VADPT in ICR #10061
; Reference to XLFDT in ICR #10103
; Reference to XLFNAME in ICR #3065
; Reference to XLFSTR in ICR #10104
;
BLDRPT(RESULTS,ADMIN,MAXWIDTH) ;
N ADATA,ANS,INST,LP,PDATA,RPT,RSTR,SCL,SWAP,YSDATA,YS,TSTNM
I '$D(^YTT(601.84,ADMIN,0)) D SETERROR^YTQRUTL(404,"Not Found: "_ADMIN) Q
S INST=$P(^YTT(601.84,ADMIN,0),U,3)
I $P($G(^YTT(601.71,INST,8)),U,3)="Y" D QUIT ; call legacy report
. N I,J
. S YS("AD")=ADMIN
. D LEGACY^YTQAPI8(.YSDATA,.YS)
. ; only have 1 empty line at the top
. S I=0 F S I=$O(^TMP("YSDATA",$J,1,I)) Q:'I Q:$L(^TMP("YSDATA",$J,1,I))
. S I=I-2,J=0 F S I=$O(^TMP("YSDATA",$J,1,I)) Q:'I S J=J+1,RESULTS(J)=^(I)
; continue here if not legacy report
I '$D(^YTT(601.93,"C",INST)) D SETERROR^YTQRUTL(404,"Not Found: "_INST) Q
S RPT=$O(^YTT(601.93,"C",INST,"")) I '$G(RPT) D SETERROR^YTQRUTL(404,"Not Found: "_INST) Q
S YS("AD")=ADMIN
S TSTNM=$P($G(^YTT(601.71,$P(^YTT(601.84,ADMIN,0),U,3),0)),U)
K ^TMP($J)
D ADMINFO(.ADATA,ADMIN) ;get Administration information
D PATINFO(.PDATA,ADATA("DFN")) ;get Patient demographic information
D SWAPIT ;load report variables with data
D GETSCORE^YTQAPI8(.YSDATA,.YS) ;get scale scores
D SETSCL ;put in array to swap values
D ALLANS^YTQAPI2(.YSDATA,.YS) ;get answers
D SWAPANS ;load report answer vars with data
D LOADTLT(.RSTR,RPT) ;load the report template
I '$D(RSTR) D SETERROR^YTQRUTL(404,"Not Found: "_RPT) Q
I $P(^YTT(601.71,+$P(^YTT(601.93,RPT,0),U,2),0),U)="AUDC" D VARYAUDC(.RSTR,ADMIN)
D GETDATA ;insert the data from the answer vars
I $G(MAXWIDTH)>1 D WRAPTLT(.RSTR,MAXWIDTH) ; wrap for progress notes
;Loop back through completed array to replace "|" (line feeds) with a blank line with a space
D FIXP(.RSTR,.RESULTS)
Q
LOADTLT(TLT,RPT) ; Load template for RPT into .TLT split by "|" chars
; resulting TLT array uses $C(10) to represent line breaks
N LP,LN,LF,FRAG,X,START,END
S LF=$C(10),LN=0,FRAG=" "
S LP=0 F S LP=$O(^YTT(601.93,RPT,1,LP)) Q:'LP D
. S X=^YTT(601.93,RPT,1,LP,0)
. I LP=1 S X=$$RMVDOTS(X) ; drop initial dots, linefeeds
. I X["$~" S X=$P(X,"$~"),LP=9999999 ; $~ marks end of report
. S START=0 F S END=$F(X,"|",START) D Q:'START
. . I END D Q
. . . S LN=LN+1
. . . S TLT(LN)=FRAG_$E(X,START,END-2)_LF
. . . S FRAG=" ",START=END
. . E D
. . . S FRAG=FRAG_$E(X,START,$L(X))
. . . S START=0
I $L(FRAG) S LN=LN+1,TLT(LN)=FRAG_LF
Q
RMVDOTS(X) ; Return X with the initial line feed / dots removed
N I,FVC S FVC=0 F I=1:1 D Q:FVC
. Q:$E(X,I)="|" Q:$E(X,I)=" " Q:$E(X,I)="."
. S FVC=I
F I=FVC:-1:0 Q:$E(X,I)="|"
Q $E(X,I+1,$L(X))
;
WRAPTLT(TLT,MAX) ; Wrap lines in TLT that are >WIDTH by adding $C(10)
N I
S I=0 F S I=$O(TLT(I)) Q:'I I $L(TLT(I))'<MAX S TLT(I)=$$WRAP(TLT(I),MAX)
Q
FIXP(RSTR,RESULTS) ;
N LP,LN,LF,FRAG,START,END
S LN=0,LF=$C(10),FRAG=""
S LP=0 F S LP=$O(RSTR(LP)) Q:'LP D
. S START=0 F S END=$F(RSTR(LP),LF,START) D Q:'START
. . I END D Q
. . . S LN=LN+1
. . . S RESULTS(LN)=FRAG_$E(RSTR(LP),START,END-2)
. . . I RESULTS(LN)="." S RESULTS(LN)=" "
. . . S FRAG="",START=END
. . E D
. . . S FRAG=FRAG_$E(RSTR(LP),START,$L(RSTR(LP)))
. . . S START=0
Q
GETDATA ;
N LP
S LP=0 F S LP=$O(RSTR(LP)) Q:'LP S RSTR(LP)=$$REPLACE^XLFSTR(RSTR(LP),.SWAP)
Q
ADMINFO(ADATA,ADMIN) ;
N CLIN,DATA,MYNAME
S DATA=^YTT(601.84,ADMIN,0)
S CLIN=$$GET1^DIQ(601.84,ADMIN_",",5,"I")
S MYNAME("FILE")=200
S MYNAME("FIELD")=.01
S MYNAME("IENS")=CLIN_","
S ADATA("DFN")=$P($G(^YTT(601.84,ADMIN,0)),U,2)
S ADATA("DATE")=$$FMTE^XLFDT($P($G(^YTT(601.84,ADMIN,0)),U,4),"5DZ")
S ADATA("ORDERED")=$$NAMEFMT^XLFNAME(.MYNAME,"F","MCXc") ;Ordered by
S ADATA("LOC")=$$TITLE^XLFSTR($$GET1^DIQ(601.84,ADMIN_",",13)) ;Location
Q
PATINFO(PDATA,DFN) ;
N MYNAME,DOB
I '$G(DFN) Q
S MYNAME("FILE")=2
S MYNAME("FIELD")=.01
S MYNAME("IENS")=DFN_","
S PDATA("NM")=$$NAMEFMT^XLFNAME(.MYNAME,"F","MCXc")
D DEM^VADPT
S PDATA("SSN")="xxx-xx-"_VA("BID")
S DOB=$P(VADM(3),U,2),$E(DOB,2,3)=$$LOW^XLFSTR($E(DOB,2,3))
S PDATA("DOB")=DOB
S PDATA("AGE")=$P(VADM(4),U)
I $L($P($G(VADM(14,5)),U,2)) D
. S PDATA("GENDER")=$P(VADM(14,5),U)
E D
. S PDATA("GENDER")=$$SENTENCE^XLFSTR($P(VADM(5),U,2))
D KVA^VADPT
Q
SWAPIT ;
N LP,TXT
F LP=1:1 S TXT=$T(SWAP+LP) Q:TXT["zzzzz" S SWAP($P(TXT,";;",2))=@($P(TXT,";;",3))
S SWAP("<.DLL_String.>")="Complex Instrument"
Q
SWAP ;
;;<.Date_Given.>;ADATA("DATE")
;;<.Staff_Ordered_By.>;ADATA("ORDERED")
;;<.Location.>;ADATA("LOC")
;;<.Patient_Name_Last_First.>;PDATA("NM")
;;<.Patient_SSN.>;PDATA("SSN")
;;<.Patient_Date_Of_Birth.>;PDATA("DOB")
;;<.Patient_Age.>;PDATA("AGE")
;;<.Patient_Gender.>;PDATA("GENDER")
;;zzzzz
Q
SWAPANS ;
N QSTN,SEQ,ANS,ANSID,LP,STR,MAX,X
I '$D(YSDATA)!($G(YSDATA(1))'="[DATA]") Q
S MAX=$S($G(MAXWIDTH):MAXWIDTH,1:80)
F QSTN=7771:1:7787 S SWAP("<*Answer_"_QSTN_"*>")="" ; default for computed
S LP=2 F S LP=$O(YSDATA(LP)) Q:'LP D
. S QSTN=$P(YSDATA(LP),U),SEQ=$P(YSDATA(LP),U,2),ANS=$P(YSDATA(LP),U,3)
. S ANSID="<*Answer_"_QSTN_"*>"
. I ANS["|" S ANS=$$FMTANS(ANS) ; replace "|" chars with LF_" "
. ; <*Answer_999999999999*> is the DLL string (special code for MMPI-2-RF)
. I QSTN=999999999999 S SWAP(ANSID)=$S(TSTNM="MMPI-2-RF":$TR(ANS,":","|"),1:ANS) Q
. ; text answers (and 7771:7787) have ";" in the sequence
. I SEQ[";" S SWAP(ANSID)=$G(SWAP(ANSID))_ANS Q
. ; capitalize skipped, special text for AUDC
. I ANS=1155 S SWAP(ANSID)="SKIPPED" Q
. I ANS=1156 D Q
. . I TSTNM="AUDC" S SWAP(ANSID)="Not asked (patient reports no drinking in past year)" I 1
. . E S SWAP(ANSID)="Not asked (due to responses to other questions)"
. I ANS=1157 S SWAP(ANSID)="Skipped, but required" Q
. ; get text for multiple choice questions
. I $P($G(^YTT(601.72,QSTN,2)),U,2)=1 S SWAP(ANSID)=$P($G(^YTT(601.75,ANS,1)),U) Q
. ; unanswered date question
. I ANS="12/30/1899" S SWAP(ANSID)="" Q
. ; bad data answer
. I ANS="[BAD DATA]" S SWAP(ANSID)="Not Specified" Q
. ; otherwise
. S SWAP(ANSID)=ANS
;
; loop thru SWAP array & make sure all responses wrapped to MAX chars
S X="<*" F S X=$O(SWAP(X)) Q:'$L(X) Q:$E(X,1,2)'="<*" D
. I $L(SWAP(X))'>MAX Q ; already under max chars
. I X="<*Answer_999999999999*>" Q ; DLLStr already wrapped
. S SWAP(X)=$$WRAP(SWAP(X),MAX) ; wrap by adding | chars
Q
FMTANS(ANS) ; return answer string with $C(10))_" " for "|" chars
N SWITCH S SWITCH("|")=$C(10)_" "
Q $$REPLACE^XLFSTR(ANS,.SWITCH)
;
SETSCL ;
N LP,STR
I '$D(^TMP($J,"YSCOR")) Q
F LP=2:1 Q:('$D(^TMP($J,"YSCOR",LP)))!($G(^TMP($J,"YSCOR",1))="[ERROR]") D
.S STR=$G(^TMP($J,"YSCOR",LP))
.S SWAP("<-"_$P(STR,"=")_"->")=$P($P(STR,"=",2),U) ; use raw score
Q
WRAP(TX,MAX) ; If length of TX > MAX, wrap by adding $C(10)
N OUT,I,J,X,Y,YNEW,LF
S LF=$C(10)
F I=1:1:$L(TX,LF) S X=$P(TX,LF,I) D
. I $L(X)'>MAX D ADDOUT(X) QUIT
. S Y=""
. F J=1:1:$L(X," ") D
. . S YNEW=Y_$S(J=1:"",1:" ")_$P(X," ",J)
. . I $L(YNEW)>MAX D ADDOUT(Y) S Y=$P(X," ",J) I 1
. . E S Y=YNEW
. D ADDOUT(Y) ; add any remaining
S X="",I=0 F S I=$O(OUT(I)) Q:'I S X=X_$S(I=1:"",1:LF)_OUT(I)
Q X
;
ADDOUT(S) ; add string to out array (expects OUT)
S OUT=+$G(OUT)+1,OUT(OUT)=S
Q
;
; special for AUDC -- hope to come up with a more general solution
;
VARYAUDC(TLT,ADMIN) ; modify .TLT for AUDC based on patient sex
N DFN,I,DONE,X1,X2,ENSRC
S DFN=+$P($G(^YTT(601.84,ADMIN,0)),U,2) QUIT:'DFN
I $P($G(^DPT(DFN,0)),U,2)'="F" QUIT ; only change if female
S ENSRC=+$P($G(^YTT(601.84,ADMIN,0)),U,13) Q:'ENSRC ; not from MHA
; looking for the 3rd question, so start checked at about line 8
S DONE=0,I=8 F S I=$O(TLT(I)) Q:'I D Q:DONE
. I TLT(I)'["six or more" QUIT
. S X1=$P(TLT(I),"six or more"),X2=$P(TLT(I),"six or more",2)
. S TLT(I)=X1_"4 or more"_X2,DONE=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRRPT 8281 printed Jan 18, 2025@03:20:10 Page 2
YTQRRPT ;SLC/LLH - Report Builder ; 08/13/2018
+1 ;;5.01;MENTAL HEALTH;**130,141,172,218**;Dec 30, 1994;Build 9
+2 ;
+3 ; Reference to DIQ in ICR #2056
+4 ; Reference to VADPT in ICR #10061
+5 ; Reference to XLFDT in ICR #10103
+6 ; Reference to XLFNAME in ICR #3065
+7 ; Reference to XLFSTR in ICR #10104
+8 ;
BLDRPT(RESULTS,ADMIN,MAXWIDTH) ;
+1 NEW ADATA,ANS,INST,LP,PDATA,RPT,RSTR,SCL,SWAP,YSDATA,YS,TSTNM
+2 IF '$DATA(^YTT(601.84,ADMIN,0))
DO SETERROR^YTQRUTL(404,"Not Found: "_ADMIN)
QUIT
+3 SET INST=$PIECE(^YTT(601.84,ADMIN,0),U,3)
+4 ; call legacy report
IF $PIECE($GET(^YTT(601.71,INST,8)),U,3)="Y"
Begin DoDot:1
+5 NEW I,J
+6 SET YS("AD")=ADMIN
+7 DO LEGACY^YTQAPI8(.YSDATA,.YS)
+8 ; only have 1 empty line at the top
+9 SET I=0
FOR
SET I=$ORDER(^TMP("YSDATA",$JOB,1,I))
if 'I
QUIT
if $LENGTH(^TMP("YSDATA",$JOB,1,I))
QUIT
+10 SET I=I-2
SET J=0
FOR
SET I=$ORDER(^TMP("YSDATA",$JOB,1,I))
if 'I
QUIT
SET J=J+1
SET RESULTS(J)=^(I)
End DoDot:1
QUIT
+11 ; continue here if not legacy report
+12 IF '$DATA(^YTT(601.93,"C",INST))
DO SETERROR^YTQRUTL(404,"Not Found: "_INST)
QUIT
+13 SET RPT=$ORDER(^YTT(601.93,"C",INST,""))
IF '$GET(RPT)
DO SETERROR^YTQRUTL(404,"Not Found: "_INST)
QUIT
+14 SET YS("AD")=ADMIN
+15 SET TSTNM=$PIECE($GET(^YTT(601.71,$PIECE(^YTT(601.84,ADMIN,0),U,3),0)),U)
+16 KILL ^TMP($JOB)
+17 ;get Administration information
DO ADMINFO(.ADATA,ADMIN)
+18 ;get Patient demographic information
DO PATINFO(.PDATA,ADATA("DFN"))
+19 ;load report variables with data
DO SWAPIT
+20 ;get scale scores
DO GETSCORE^YTQAPI8(.YSDATA,.YS)
+21 ;put in array to swap values
DO SETSCL
+22 ;get answers
DO ALLANS^YTQAPI2(.YSDATA,.YS)
+23 ;load report answer vars with data
DO SWAPANS
+24 ;load the report template
DO LOADTLT(.RSTR,RPT)
+25 IF '$DATA(RSTR)
DO SETERROR^YTQRUTL(404,"Not Found: "_RPT)
QUIT
+26 IF $PIECE(^YTT(601.71,+$PIECE(^YTT(601.93,RPT,0),U,2),0),U)="AUDC"
DO VARYAUDC(.RSTR,ADMIN)
+27 ;insert the data from the answer vars
DO GETDATA
+28 ; wrap for progress notes
IF $GET(MAXWIDTH)>1
DO WRAPTLT(.RSTR,MAXWIDTH)
+29 ;Loop back through completed array to replace "|" (line feeds) with a blank line with a space
+30 DO FIXP(.RSTR,.RESULTS)
+31 QUIT
LOADTLT(TLT,RPT) ; Load template for RPT into .TLT split by "|" chars
+1 ; resulting TLT array uses $C(10) to represent line breaks
+2 NEW LP,LN,LF,FRAG,X,START,END
+3 SET LF=$CHAR(10)
SET LN=0
SET FRAG=" "
+4 SET LP=0
FOR
SET LP=$ORDER(^YTT(601.93,RPT,1,LP))
if 'LP
QUIT
Begin DoDot:1
+5 SET X=^YTT(601.93,RPT,1,LP,0)
+6 ; drop initial dots, linefeeds
IF LP=1
SET X=$$RMVDOTS(X)
+7 ; $~ marks end of report
IF X["$~"
SET X=$PIECE(X,"$~")
SET LP=9999999
+8 SET START=0
FOR
SET END=$FIND(X,"|",START)
Begin DoDot:2
+9 IF END
Begin DoDot:3
+10 SET LN=LN+1
+11 SET TLT(LN)=FRAG_$EXTRACT(X,START,END-2)_LF
+12 SET FRAG=" "
SET START=END
End DoDot:3
QUIT
+13 IF '$TEST
Begin DoDot:3
+14 SET FRAG=FRAG_$EXTRACT(X,START,$LENGTH(X))
+15 SET START=0
End DoDot:3
End DoDot:2
if 'START
QUIT
End DoDot:1
+16 IF $LENGTH(FRAG)
SET LN=LN+1
SET TLT(LN)=FRAG_LF
+17 QUIT
RMVDOTS(X) ; Return X with the initial line feed / dots removed
+1 NEW I,FVC
SET FVC=0
FOR I=1:1
Begin DoDot:1
+2 if $EXTRACT(X,I)="|"
QUIT
if $EXTRACT(X,I)=" "
QUIT
if $EXTRACT(X,I)="."
QUIT
+3 SET FVC=I
End DoDot:1
if FVC
QUIT
+4 FOR I=FVC:-1:0
if $EXTRACT(X,I)="|"
QUIT
+5 QUIT $EXTRACT(X,I+1,$LENGTH(X))
+6 ;
WRAPTLT(TLT,MAX) ; Wrap lines in TLT that are >WIDTH by adding $C(10)
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(TLT(I))
if 'I
QUIT
IF $LENGTH(TLT(I))'<MAX
SET TLT(I)=$$WRAP(TLT(I),MAX)
+3 QUIT
FIXP(RSTR,RESULTS) ;
+1 NEW LP,LN,LF,FRAG,START,END
+2 SET LN=0
SET LF=$CHAR(10)
SET FRAG=""
+3 SET LP=0
FOR
SET LP=$ORDER(RSTR(LP))
if 'LP
QUIT
Begin DoDot:1
+4 SET START=0
FOR
SET END=$FIND(RSTR(LP),LF,START)
Begin DoDot:2
+5 IF END
Begin DoDot:3
+6 SET LN=LN+1
+7 SET RESULTS(LN)=FRAG_$EXTRACT(RSTR(LP),START,END-2)
+8 IF RESULTS(LN)="."
SET RESULTS(LN)=" "
+9 SET FRAG=""
SET START=END
End DoDot:3
QUIT
+10 IF '$TEST
Begin DoDot:3
+11 SET FRAG=FRAG_$EXTRACT(RSTR(LP),START,$LENGTH(RSTR(LP)))
+12 SET START=0
End DoDot:3
End DoDot:2
if 'START
QUIT
End DoDot:1
+13 QUIT
GETDATA ;
+1 NEW LP
+2 SET LP=0
FOR
SET LP=$ORDER(RSTR(LP))
if 'LP
QUIT
SET RSTR(LP)=$$REPLACE^XLFSTR(RSTR(LP),.SWAP)
+3 QUIT
ADMINFO(ADATA,ADMIN) ;
+1 NEW CLIN,DATA,MYNAME
+2 SET DATA=^YTT(601.84,ADMIN,0)
+3 SET CLIN=$$GET1^DIQ(601.84,ADMIN_",",5,"I")
+4 SET MYNAME("FILE")=200
+5 SET MYNAME("FIELD")=.01
+6 SET MYNAME("IENS")=CLIN_","
+7 SET ADATA("DFN")=$PIECE($GET(^YTT(601.84,ADMIN,0)),U,2)
+8 SET ADATA("DATE")=$$FMTE^XLFDT($PIECE($GET(^YTT(601.84,ADMIN,0)),U,4),"5DZ")
+9 ;Ordered by
SET ADATA("ORDERED")=$$NAMEFMT^XLFNAME(.MYNAME,"F","MCXc")
+10 ;Location
SET ADATA("LOC")=$$TITLE^XLFSTR($$GET1^DIQ(601.84,ADMIN_",",13))
+11 QUIT
PATINFO(PDATA,DFN) ;
+1 NEW MYNAME,DOB
+2 IF '$GET(DFN)
QUIT
+3 SET MYNAME("FILE")=2
+4 SET MYNAME("FIELD")=.01
+5 SET MYNAME("IENS")=DFN_","
+6 SET PDATA("NM")=$$NAMEFMT^XLFNAME(.MYNAME,"F","MCXc")
+7 DO DEM^VADPT
+8 SET PDATA("SSN")="xxx-xx-"_VA("BID")
+9 SET DOB=$PIECE(VADM(3),U,2)
SET $EXTRACT(DOB,2,3)=$$LOW^XLFSTR($EXTRACT(DOB,2,3))
+10 SET PDATA("DOB")=DOB
+11 SET PDATA("AGE")=$PIECE(VADM(4),U)
+12 IF $LENGTH($PIECE($GET(VADM(14,5)),U,2))
Begin DoDot:1
+13 SET PDATA("GENDER")=$PIECE(VADM(14,5),U)
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 SET PDATA("GENDER")=$$SENTENCE^XLFSTR($PIECE(VADM(5),U,2))
End DoDot:1
+16 DO KVA^VADPT
+17 QUIT
SWAPIT ;
+1 NEW LP,TXT
+2 FOR LP=1:1
SET TXT=$TEXT(SWAP+LP)
if TXT["zzzzz"
QUIT
SET SWAP($PIECE(TXT,";;",2))=@($PIECE(TXT,";;",3))
+3 SET SWAP("<.DLL_String.>")="Complex Instrument"
+4 QUIT
SWAP ;
+1 ;;<.Date_Given.>;ADATA("DATE")
+2 ;;<.Staff_Ordered_By.>;ADATA("ORDERED")
+3 ;;<.Location.>;ADATA("LOC")
+4 ;;<.Patient_Name_Last_First.>;PDATA("NM")
+5 ;;<.Patient_SSN.>;PDATA("SSN")
+6 ;;<.Patient_Date_Of_Birth.>;PDATA("DOB")
+7 ;;<.Patient_Age.>;PDATA("AGE")
+8 ;;<.Patient_Gender.>;PDATA("GENDER")
+9 ;;zzzzz
+10 QUIT
SWAPANS ;
+1 NEW QSTN,SEQ,ANS,ANSID,LP,STR,MAX,X
+2 IF '$DATA(YSDATA)!($GET(YSDATA(1))'="[DATA]")
QUIT
+3 SET MAX=$SELECT($GET(MAXWIDTH):MAXWIDTH,1:80)
+4 ; default for computed
FOR QSTN=7771:1:7787
SET SWAP("<*Answer_"_QSTN_"*>")=""
+5 SET LP=2
FOR
SET LP=$ORDER(YSDATA(LP))
if 'LP
QUIT
Begin DoDot:1
+6 SET QSTN=$PIECE(YSDATA(LP),U)
SET SEQ=$PIECE(YSDATA(LP),U,2)
SET ANS=$PIECE(YSDATA(LP),U,3)
+7 SET ANSID="<*Answer_"_QSTN_"*>"
+8 ; replace "|" chars with LF_" "
IF ANS["|"
SET ANS=$$FMTANS(ANS)
+9 ; <*Answer_999999999999*> is the DLL string (special code for MMPI-2-RF)
+10 IF QSTN=999999999999
SET SWAP(ANSID)=$SELECT(TSTNM="MMPI-2-RF":$TRANSLATE(ANS,":","|"),1:ANS)
QUIT
+11 ; text answers (and 7771:7787) have ";" in the sequence
+12 IF SEQ[";"
SET SWAP(ANSID)=$GET(SWAP(ANSID))_ANS
QUIT
+13 ; capitalize skipped, special text for AUDC
+14 IF ANS=1155
SET SWAP(ANSID)="SKIPPED"
QUIT
+15 IF ANS=1156
Begin DoDot:2
+16 IF TSTNM="AUDC"
SET SWAP(ANSID)="Not asked (patient reports no drinking in past year)"
IF 1
+17 IF '$TEST
SET SWAP(ANSID)="Not asked (due to responses to other questions)"
End DoDot:2
QUIT
+18 IF ANS=1157
SET SWAP(ANSID)="Skipped, but required"
QUIT
+19 ; get text for multiple choice questions
+20 IF $PIECE($GET(^YTT(601.72,QSTN,2)),U,2)=1
SET SWAP(ANSID)=$PIECE($GET(^YTT(601.75,ANS,1)),U)
QUIT
+21 ; unanswered date question
+22 IF ANS="12/30/1899"
SET SWAP(ANSID)=""
QUIT
+23 ; bad data answer
+24 IF ANS="[BAD DATA]"
SET SWAP(ANSID)="Not Specified"
QUIT
+25 ; otherwise
+26 SET SWAP(ANSID)=ANS
End DoDot:1
+27 ;
+28 ; loop thru SWAP array & make sure all responses wrapped to MAX chars
+29 SET X="<*"
FOR
SET X=$ORDER(SWAP(X))
if '$LENGTH(X)
QUIT
if $EXTRACT(X,1,2)'="<*"
QUIT
Begin DoDot:1
+30 ; already under max chars
IF $LENGTH(SWAP(X))'>MAX
QUIT
+31 ; DLLStr already wrapped
IF X="<*Answer_999999999999*>"
QUIT
+32 ; wrap by adding | chars
SET SWAP(X)=$$WRAP(SWAP(X),MAX)
End DoDot:1
+33 QUIT
FMTANS(ANS) ; return answer string with $C(10))_" " for "|" chars
+1 NEW SWITCH
SET SWITCH("|")=$CHAR(10)_" "
+2 QUIT $$REPLACE^XLFSTR(ANS,.SWITCH)
+3 ;
SETSCL ;
+1 NEW LP,STR
+2 IF '$DATA(^TMP($JOB,"YSCOR"))
QUIT
+3 FOR LP=2:1
if ('$DATA(^TMP($JOB,"YSCOR",LP)))!($GET(^TMP($JOB,"YSCOR",1))="[ERROR]")
QUIT
Begin DoDot:1
+4 SET STR=$GET(^TMP($JOB,"YSCOR",LP))
+5 ; use raw score
SET SWAP("<-"_$PIECE(STR,"=")_"->")=$PIECE($PIECE(STR,"=",2),U)
End DoDot:1
+6 QUIT
WRAP(TX,MAX) ; If length of TX > MAX, wrap by adding $C(10)
+1 NEW OUT,I,J,X,Y,YNEW,LF
+2 SET LF=$CHAR(10)
+3 FOR I=1:1:$LENGTH(TX,LF)
SET X=$PIECE(TX,LF,I)
Begin DoDot:1
+4 IF $LENGTH(X)'>MAX
DO ADDOUT(X)
QUIT
+5 SET Y=""
+6 FOR J=1:1:$LENGTH(X," ")
Begin DoDot:2
+7 SET YNEW=Y_$SELECT(J=1:"",1:" ")_$PIECE(X," ",J)
+8 IF $LENGTH(YNEW)>MAX
DO ADDOUT(Y)
SET Y=$PIECE(X," ",J)
IF 1
+9 IF '$TEST
SET Y=YNEW
End DoDot:2
+10 ; add any remaining
DO ADDOUT(Y)
End DoDot:1
+11 SET X=""
SET I=0
FOR
SET I=$ORDER(OUT(I))
if 'I
QUIT
SET X=X_$SELECT(I=1:"",1:LF)_OUT(I)
+12 QUIT X
+13 ;
ADDOUT(S) ; add string to out array (expects OUT)
+1 SET OUT=+$GET(OUT)+1
SET OUT(OUT)=S
+2 QUIT
+3 ;
+4 ; special for AUDC -- hope to come up with a more general solution
+5 ;
VARYAUDC(TLT,ADMIN) ; modify .TLT for AUDC based on patient sex
+1 NEW DFN,I,DONE,X1,X2,ENSRC
+2 SET DFN=+$PIECE($GET(^YTT(601.84,ADMIN,0)),U,2)
if 'DFN
QUIT
+3 ; only change if female
IF $PIECE($GET(^DPT(DFN,0)),U,2)'="F"
QUIT
+4 ; not from MHA
SET ENSRC=+$PIECE($GET(^YTT(601.84,ADMIN,0)),U,13)
if 'ENSRC
QUIT
+5 ; looking for the 3rd question, so start checked at about line 8
+6 SET DONE=0
SET I=8
FOR
SET I=$ORDER(TLT(I))
if 'I
QUIT
Begin DoDot:1
+7 IF TLT(I)'["six or more"
QUIT
+8 SET X1=$PIECE(TLT(I),"six or more")
SET X2=$PIECE(TLT(I),"six or more",2)
+9 SET TLT(I)=X1_"4 or more"_X2
SET DONE=1
End DoDot:1
if DONE
QUIT
+10 QUIT
