- 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 Mar 13, 2025@21:26:56 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 ;
