YTXCHGE ;SLC/KCM - Instrument Specification Export ; 9/15/2015
;;5.01;MENTAL HEALTH;**121,172**;Dec 30, 1994;Build 10
;
EXPORT(TEST,DEST) ; extract test entries into DEST array
; TEST -- name or IEN of mental health instrument
; DEST -- closed array reference for destination JSON
; caller must make sure DEST is empty
I 'TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) Q:'TEST
;
N MAP,JSONERR,DISPLAY,YTXCHGDT
S $E(DEST,$L(DEST))="," ; use open array ref
D BLDMAP^YTXCHGM(.MAP) ; build file:field to JSON name map
D LDINFO(TEST) ; load the instrument information
D LDCTNT(TEST) ; load the instrument content
D LDSCLS(TEST) ; load the instrument scales
D LDRULE(TEST) ; load the instrument rules
D LDREPT(TEST) ; load the instrument report
D LDSPEC(TEST) ; load the instrument entry spec
D LDDISP ; load the display formatting entries
D LDVER(TEST) ; load the verify entries
Q
LDINFO(TEST) ; load general information for instrument
; use entry from MH TESTS AND SURVEYS file (601.71)
D REC2JSON(601.71,TEST_",")
N SECIEN,NUMS
S SECIEN=0 F S SECIEN=$O(^YTT(601.81,"AC",TEST,SECIEN)) Q:'SECIEN D
. S NUMS(1)=$G(NUMS(1))+1
. D REC2JSON(601.81,SECIEN_",",.NUMS)
Q
LDCTNT(TEST) ; load question/choice content for instrument
; loop through "AD" xref in MH INSTRUMENT CONTENT for each question
; loop through "AC" xref in MH CHOICETYPES for each choice
N SEQ,CTNT,QSTN,X0,X2,NUMS,CTYP,CIDF,CSEQ,CHID,CIEN
S SEQ=0 F S SEQ=$O(^YTT(601.76,"AD",TEST,SEQ)) Q:'SEQ D
. S CTNT=0 F S CTNT=$O(^YTT(601.76,"AD",TEST,SEQ,CTNT)) Q:'CTNT D
. . S NUMS(1)=$G(NUMS(1))+1
. . S X0=^YTT(601.76,CTNT,0),QSTN=$P(X0,U,4)
. . S X2=^YTT(601.72,QSTN,2),CTYP=$P(X2,U,3)
. . D REC2JSON(601.76,CTNT_",",.NUMS) ; content entry
. . D REC2JSON(601.72,QSTN_",",.NUMS) ; question
. . D REC2JSON(601.73,$P(X2,U,1)_",",.NUMS) ; introduction
. . D REC2JSON(601.74,$P(X2,U,2)_",",.NUMS) ; response type
. . Q:'CTYP
. . S CIDF=$O(^YTT(601.89,"B",CTYP,0)) ; choice identifier ien
. . D REC2JSON(601.89,CIDF_",",.NUMS) ; choice identifier
. . S CSEQ=0 F S CSEQ=$O(^YTT(601.751,"AC",CTYP,CSEQ)) Q:'CSEQ D
. . . S CHID=0 F S CHID=$O(^YTT(601.751,"AC",CTYP,CSEQ,CHID)) Q:'CHID D
. . . . S CIEN=0 F S CIEN=$O(^YTT(601.751,"AC",CTYP,CSEQ,CHID,CIEN)) Q:'CIEN D
. . . . . S NUMS(2)=$G(NUMS(2))+1
. . . . . D REC2JSON(601.751,CIEN_",",.NUMS) ; choice type entry
. . . . . D REC2JSON(601.75,CHID_",",.NUMS) ; choice entry
. . K NUMS(2) ; reset for next set
Q
LDSCLS(TEST) ; load scale information for instrument
; loop thru "AC" xref in MH SCALEGROUPS for each group (testId,seq,groupId)
; loop thru "AC" xref in MH SCALES for each scale (groupId,seq,scaleId)
; loop thru "AC" xref in MH SCORING KEYS for each key (scaleId,keyId)
N GSEQ,GID,SSEQ,SID,KID,NUMS
S GSEQ=0 F S GSEQ=$O(^YTT(601.86,"AC",TEST,GSEQ)) Q:'GSEQ D
. S GID=0 F S GID=$O(^YTT(601.86,"AC",TEST,GSEQ,GID)) Q:'GID D
. . S NUMS(1)=$G(NUMS(1))+1
. . D REC2JSON(601.86,GID_",",.NUMS)
. . S SSEQ=0 F S SSEQ=$O(^YTT(601.87,"AC",GID,SSEQ)) Q:'SSEQ D
. . . S SID=0 F S SID=$O(^YTT(601.87,"AC",GID,SSEQ,SID)) Q:'SID D
. . . . S NUMS(2)=$G(NUMS(2))+1
. . . . D REC2JSON(601.87,SID_",",.NUMS)
. . . . S KID=0 F S KID=$O(^YTT(601.91,"AC",SID,KID)) Q:'KID D
. . . . . S NUMS(3)=$G(NUMS(3))+1
. . . . . D REC2JSON(601.91,KID_",",.NUMS)
. . . . K NUMS(3)
. . K NUMS(2)
Q
LDRULE(TEST) ; load rule information for instrument
N NUMS,IEN,RIEN,SIEN
S IEN=0 F S IEN=$O(^YTT(601.83,"C",TEST,IEN)) Q:'IEN D
. S NUMS(1)=$G(NUMS(1))+1
. D REC2JSON(601.83,IEN_",",.NUMS)
. S RIEN=$P(^YTT(601.83,IEN,0),U,4)
. D REC2JSON(601.82,RIEN_",",.NUMS)
. S SIEN=0 F S SIEN=$O(^YTT(601.79,"AE",RIEN,SIEN)) Q:'SIEN D
. . S NUMS(2)=$G(NUMS(2))+1
. . D REC2JSON(601.79,SIEN_",",.NUMS)
. K RNUMS
Q
LDREPT(TEST) ; load the report for an instrument
N IEN
S IEN=$O(^YTT(601.93,"C",TEST,0)) ; use first IEN if multiple for reports
D REC2JSON(601.93,IEN_",")
Q
LDSPEC(TEST) ; load the web entry specification for an instrument
N IEN
S IEN=$O(^YTT(601.712,"B",TEST,0))
D REC2JSON(601.712,IEN_",")
Q
LDDISP ; load display information from IEN's in DISPLAY
; loop thru IEN's saved in DISPLAY
N IEN,NUMS
S IEN=0 F S IEN=$O(DISPLAY(IEN)) Q:'IEN D
. S NUMS(1)=$G(NUMS(1))+1
. D REC2JSON(601.88,IEN_",",.NUMS)
Q
LDVER(TEST) ; load the verify values for an instrument
; expects DEST
K ^TMP($J,"local")
N FILE,IEN,CNT,ROOT
S ROOT=$E(DEST,1,$L(DEST)-1)_")" ; use closed array
D BLDTEST^YTXCHGV(TEST,$NA(^TMP($J,"local")))
S FILE=0 F S FILE=$O(^TMP($J,"local",FILE)) Q:'FILE D
. S IEN=0 F S IEN=$O(^TMP($J,"local",FILE,IEN)) Q:'IEN D
. . S CNT=+$G(CNT)+1
. . S @ROOT@("verify",CNT)=FILE_":"_IEN
K ^TMP($J,"local")
Q
;
REC2JSON(FILE,IENS,NUMS) ; load record into JSON using MAP
; expects MAP,DEST
; FILE -- mh file number
; IENS -- IEN string (with trailing comma)
; NUMS -- array numbers for JSON array
N FLDS,VALS,ERRS,FLD,SUBS,I,TARGET
S FLDS=$$FILEFLDS(FILE)
D GETS^DIQ(FILE,IENS,FLDS,"INZ","VALS","ERRS") ;"IN": internal vals, no nulls
I $D(MAP(FILE,.001)) S VALS(FILE,IENS,.001,"I")=+IENS
S FLD=0 F S FLD=$O(MAP(FILE,FLD)) Q:'FLD D
. ; Q:'$D(VALS(FILE,IENS,FLD,"I"))
. S SUBS=$$MKSUBS^YTXCHGU(FILE,FLD,.NUMS)
. S TARGET=DEST_SUBS_")"
. I '$L($G(VALS(FILE,IENS,FLD,"I"))) D Q ; empty value
. . S @TARGET="null"
. I $G(MAP(FILE,FLD,"type"))["t" D Q ; date/time
. . S @TARGET=$$FM2ISO^YTXCHGU(VALS(FILE,IENS,FLD,"I"))
. I $G(MAP(FILE,FLD,"type"))["y" D Q ; yes/no boolean
. . S @TARGET=$S(VALS(FILE,IENS,FLD,"I")="Y":"true",1:"false")
. I $G(MAP(FILE,FLD,"type"))["d" D Q ; refs to MH DISPLAY
. . S @TARGET=VALS(FILE,IENS,FLD,"I")
. . S DISPLAY(VALS(FILE,IENS,FLD,"I"))=""
. I $G(MAP(FILE,FLD,"type"))["w" D Q ; word processing
. . D WP2TR^YTXCHGT($NA(VALS(FILE,IENS,FLD)),TARGET)
. S @TARGET=VALS(FILE,IENS,FLD,"I") ; all other fields
D LOG^YTXCHGU("prog",".")
Q
FILEFLDS(FILE) ; return a string of fields in the file
; expects MAP
N I,X
S X=""
S I=0 F S I=$O(MAP(FILE,I)) Q:'I I I'=".001" S X=X_I_";"
Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGE 6447 printed Apr 09, 2024@21:24:34 Page 2
YTXCHGE ;SLC/KCM - Instrument Specification Export ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121,172**;Dec 30, 1994;Build 10
+2 ;
EXPORT(TEST,DEST) ; extract test entries into DEST array
+1 ; TEST -- name or IEN of mental health instrument
+2 ; DEST -- closed array reference for destination JSON
+3 ; caller must make sure DEST is empty
+4 IF 'TEST
SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
if 'TEST
QUIT
+5 ;
+6 NEW MAP,JSONERR,DISPLAY,YTXCHGDT
+7 ; use open array ref
SET $EXTRACT(DEST,$LENGTH(DEST))=","
+8 ; build file:field to JSON name map
DO BLDMAP^YTXCHGM(.MAP)
+9 ; load the instrument information
DO LDINFO(TEST)
+10 ; load the instrument content
DO LDCTNT(TEST)
+11 ; load the instrument scales
DO LDSCLS(TEST)
+12 ; load the instrument rules
DO LDRULE(TEST)
+13 ; load the instrument report
DO LDREPT(TEST)
+14 ; load the instrument entry spec
DO LDSPEC(TEST)
+15 ; load the display formatting entries
DO LDDISP
+16 ; load the verify entries
DO LDVER(TEST)
+17 QUIT
LDINFO(TEST) ; load general information for instrument
+1 ; use entry from MH TESTS AND SURVEYS file (601.71)
+2 DO REC2JSON(601.71,TEST_",")
+3 NEW SECIEN,NUMS
+4 SET SECIEN=0
FOR
SET SECIEN=$ORDER(^YTT(601.81,"AC",TEST,SECIEN))
if 'SECIEN
QUIT
Begin DoDot:1
+5 SET NUMS(1)=$GET(NUMS(1))+1
+6 DO REC2JSON(601.81,SECIEN_",",.NUMS)
End DoDot:1
+7 QUIT
LDCTNT(TEST) ; load question/choice content for instrument
+1 ; loop through "AD" xref in MH INSTRUMENT CONTENT for each question
+2 ; loop through "AC" xref in MH CHOICETYPES for each choice
+3 NEW SEQ,CTNT,QSTN,X0,X2,NUMS,CTYP,CIDF,CSEQ,CHID,CIEN
+4 SET SEQ=0
FOR
SET SEQ=$ORDER(^YTT(601.76,"AD",TEST,SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+5 SET CTNT=0
FOR
SET CTNT=$ORDER(^YTT(601.76,"AD",TEST,SEQ,CTNT))
if 'CTNT
QUIT
Begin DoDot:2
+6 SET NUMS(1)=$GET(NUMS(1))+1
+7 SET X0=^YTT(601.76,CTNT,0)
SET QSTN=$PIECE(X0,U,4)
+8 SET X2=^YTT(601.72,QSTN,2)
SET CTYP=$PIECE(X2,U,3)
+9 ; content entry
DO REC2JSON(601.76,CTNT_",",.NUMS)
+10 ; question
DO REC2JSON(601.72,QSTN_",",.NUMS)
+11 ; introduction
DO REC2JSON(601.73,$PIECE(X2,U,1)_",",.NUMS)
+12 ; response type
DO REC2JSON(601.74,$PIECE(X2,U,2)_",",.NUMS)
+13 if 'CTYP
QUIT
+14 ; choice identifier ien
SET CIDF=$ORDER(^YTT(601.89,"B",CTYP,0))
+15 ; choice identifier
DO REC2JSON(601.89,CIDF_",",.NUMS)
+16 SET CSEQ=0
FOR
SET CSEQ=$ORDER(^YTT(601.751,"AC",CTYP,CSEQ))
if 'CSEQ
QUIT
Begin DoDot:3
+17 SET CHID=0
FOR
SET CHID=$ORDER(^YTT(601.751,"AC",CTYP,CSEQ,CHID))
if 'CHID
QUIT
Begin DoDot:4
+18 SET CIEN=0
FOR
SET CIEN=$ORDER(^YTT(601.751,"AC",CTYP,CSEQ,CHID,CIEN))
if 'CIEN
QUIT
Begin DoDot:5
+19 SET NUMS(2)=$GET(NUMS(2))+1
+20 ; choice type entry
DO REC2JSON(601.751,CIEN_",",.NUMS)
+21 ; choice entry
DO REC2JSON(601.75,CHID_",",.NUMS)
End DoDot:5
End DoDot:4
End DoDot:3
+22 ; reset for next set
KILL NUMS(2)
End DoDot:2
End DoDot:1
+23 QUIT
LDSCLS(TEST) ; load scale information for instrument
+1 ; loop thru "AC" xref in MH SCALEGROUPS for each group (testId,seq,groupId)
+2 ; loop thru "AC" xref in MH SCALES for each scale (groupId,seq,scaleId)
+3 ; loop thru "AC" xref in MH SCORING KEYS for each key (scaleId,keyId)
+4 NEW GSEQ,GID,SSEQ,SID,KID,NUMS
+5 SET GSEQ=0
FOR
SET GSEQ=$ORDER(^YTT(601.86,"AC",TEST,GSEQ))
if 'GSEQ
QUIT
Begin DoDot:1
+6 SET GID=0
FOR
SET GID=$ORDER(^YTT(601.86,"AC",TEST,GSEQ,GID))
if 'GID
QUIT
Begin DoDot:2
+7 SET NUMS(1)=$GET(NUMS(1))+1
+8 DO REC2JSON(601.86,GID_",",.NUMS)
+9 SET SSEQ=0
FOR
SET SSEQ=$ORDER(^YTT(601.87,"AC",GID,SSEQ))
if 'SSEQ
QUIT
Begin DoDot:3
+10 SET SID=0
FOR
SET SID=$ORDER(^YTT(601.87,"AC",GID,SSEQ,SID))
if 'SID
QUIT
Begin DoDot:4
+11 SET NUMS(2)=$GET(NUMS(2))+1
+12 DO REC2JSON(601.87,SID_",",.NUMS)
+13 SET KID=0
FOR
SET KID=$ORDER(^YTT(601.91,"AC",SID,KID))
if 'KID
QUIT
Begin DoDot:5
+14 SET NUMS(3)=$GET(NUMS(3))+1
+15 DO REC2JSON(601.91,KID_",",.NUMS)
End DoDot:5
+16 KILL NUMS(3)
End DoDot:4
End DoDot:3
+17 KILL NUMS(2)
End DoDot:2
End DoDot:1
+18 QUIT
LDRULE(TEST) ; load rule information for instrument
+1 NEW NUMS,IEN,RIEN,SIEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^YTT(601.83,"C",TEST,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 SET NUMS(1)=$GET(NUMS(1))+1
+4 DO REC2JSON(601.83,IEN_",",.NUMS)
+5 SET RIEN=$PIECE(^YTT(601.83,IEN,0),U,4)
+6 DO REC2JSON(601.82,RIEN_",",.NUMS)
+7 SET SIEN=0
FOR
SET SIEN=$ORDER(^YTT(601.79,"AE",RIEN,SIEN))
if 'SIEN
QUIT
Begin DoDot:2
+8 SET NUMS(2)=$GET(NUMS(2))+1
+9 DO REC2JSON(601.79,SIEN_",",.NUMS)
End DoDot:2
+10 KILL RNUMS
End DoDot:1
+11 QUIT
LDREPT(TEST) ; load the report for an instrument
+1 NEW IEN
+2 ; use first IEN if multiple for reports
SET IEN=$ORDER(^YTT(601.93,"C",TEST,0))
+3 DO REC2JSON(601.93,IEN_",")
+4 QUIT
LDSPEC(TEST) ; load the web entry specification for an instrument
+1 NEW IEN
+2 SET IEN=$ORDER(^YTT(601.712,"B",TEST,0))
+3 DO REC2JSON(601.712,IEN_",")
+4 QUIT
LDDISP ; load display information from IEN's in DISPLAY
+1 ; loop thru IEN's saved in DISPLAY
+2 NEW IEN,NUMS
+3 SET IEN=0
FOR
SET IEN=$ORDER(DISPLAY(IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 SET NUMS(1)=$GET(NUMS(1))+1
+5 DO REC2JSON(601.88,IEN_",",.NUMS)
End DoDot:1
+6 QUIT
LDVER(TEST) ; load the verify values for an instrument
+1 ; expects DEST
+2 KILL ^TMP($JOB,"local")
+3 NEW FILE,IEN,CNT,ROOT
+4 ; use closed array
SET ROOT=$EXTRACT(DEST,1,$LENGTH(DEST)-1)_")"
+5 DO BLDTEST^YTXCHGV(TEST,$NAME(^TMP($JOB,"local")))
+6 SET FILE=0
FOR
SET FILE=$ORDER(^TMP($JOB,"local",FILE))
if 'FILE
QUIT
Begin DoDot:1
+7 SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"local",FILE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+8 SET CNT=+$GET(CNT)+1
+9 SET @ROOT@("verify",CNT)=FILE_":"_IEN
End DoDot:2
End DoDot:1
+10 KILL ^TMP($JOB,"local")
+11 QUIT
+12 ;
REC2JSON(FILE,IENS,NUMS) ; load record into JSON using MAP
+1 ; expects MAP,DEST
+2 ; FILE -- mh file number
+3 ; IENS -- IEN string (with trailing comma)
+4 ; NUMS -- array numbers for JSON array
+5 NEW FLDS,VALS,ERRS,FLD,SUBS,I,TARGET
+6 SET FLDS=$$FILEFLDS(FILE)
+7 ;"IN": internal vals, no nulls
DO GETS^DIQ(FILE,IENS,FLDS,"INZ","VALS","ERRS")
+8 IF $DATA(MAP(FILE,.001))
SET VALS(FILE,IENS,.001,"I")=+IENS
+9 SET FLD=0
FOR
SET FLD=$ORDER(MAP(FILE,FLD))
if 'FLD
QUIT
Begin DoDot:1
+10 ; Q:'$D(VALS(FILE,IENS,FLD,"I"))
+11 SET SUBS=$$MKSUBS^YTXCHGU(FILE,FLD,.NUMS)
+12 SET TARGET=DEST_SUBS_")"
+13 ; empty value
IF '$LENGTH($GET(VALS(FILE,IENS,FLD,"I")))
Begin DoDot:2
+14 SET @TARGET="null"
End DoDot:2
QUIT
+15 ; date/time
IF $GET(MAP(FILE,FLD,"type"))["t"
Begin DoDot:2
+16 SET @TARGET=$$FM2ISO^YTXCHGU(VALS(FILE,IENS,FLD,"I"))
End DoDot:2
QUIT
+17 ; yes/no boolean
IF $GET(MAP(FILE,FLD,"type"))["y"
Begin DoDot:2
+18 SET @TARGET=$SELECT(VALS(FILE,IENS,FLD,"I")="Y":"true",1:"false")
End DoDot:2
QUIT
+19 ; refs to MH DISPLAY
IF $GET(MAP(FILE,FLD,"type"))["d"
Begin DoDot:2
+20 SET @TARGET=VALS(FILE,IENS,FLD,"I")
+21 SET DISPLAY(VALS(FILE,IENS,FLD,"I"))=""
End DoDot:2
QUIT
+22 ; word processing
IF $GET(MAP(FILE,FLD,"type"))["w"
Begin DoDot:2
+23 DO WP2TR^YTXCHGT($NAME(VALS(FILE,IENS,FLD)),TARGET)
End DoDot:2
QUIT
+24 ; all other fields
SET @TARGET=VALS(FILE,IENS,FLD,"I")
End DoDot:1
+25 DO LOG^YTXCHGU("prog",".")
+26 QUIT
FILEFLDS(FILE) ; return a string of fields in the file
+1 ; expects MAP
+2 NEW I,X
+3 SET X=""
+4 SET I=0
FOR
SET I=$ORDER(MAP(FILE,I))
if 'I
QUIT
IF I'=".001"
SET X=X_I_";"
+5 QUIT X
+6 ;
