Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTWJSON

YTWJSON.m

Go to the documentation of this file. 
  1. YTWJSON ;SLC/KCM - Generate JSON Instrument Spec ; 7/20/2018
  1.  ;;5.01;MENTAL HEALTH;**130,141,202**;Dec 30, 1994;Build 47
  1.  ;
  1.  ; Reference to %ZOSV in ICR #10097
  1.  ; Reference to %ZTER in ICR #1621
  1.  ;
  1. GETSPEC(JSON,TEST) ; Get the JSON admin spec for instrument TEST
  1.  I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) Q:'TEST
  1.  ;
  1.  N $ES,$ET S $ET="D ERRHND^YTWJSON"   ; quit from ERRHND if error
  1.  N TREE,ERR
  1.  D CONTENT(TEST,.TREE)
  1.  D RULES(TEST,.TREE)
  1.  D FMTJSON^YTWJSONO(.TREE,.JSON) ;D ENCODE^VPRJSON("TREE","JSON","ERR")
  1.  Q
  1. ERRHND ; Handle errors & clear stack
  1.  N ERROR S ERROR=$$EC^%ZOSV           ; grab the error code
  1.  I ERROR["ZTER" D UNWIND^%ZTER        ; ignore errors clearing stack
  1.  N $ET S $ET="D ^%ZTER,UNWIND^%ZTER"  ; avoid looping on add'l error
  1.  D ^%ZTER                             ; record failure in error trap
  1.  K JSON                               ; delete the return value
  1.  D UNWIND^%ZTER                       ; clear the call stack
  1.  Q
  1. CONTENT(TEST,TREE) ; build TEST spec as TREE for JSON conversion
  1.  S TREE("name")=$P(^YTT(601.71,TEST,0),U)
  1.  S TREE("printTitle")=$P(^YTT(601.71,TEST,0),U,3)
  1.  ; TODO: replace Copyright (c) with \u00A9 ??
  1.  S TREE("copyright")=$$HTMLESC^YTWJSONU($G(^YTT(601.71,TEST,7)))
  1.  S TREE("restartDays")=$P($G(^YTT(601.71,TEST,8)),U,7)
  1.  I TREE("restartDays")="" S TREE("restartDays")=2
  1.  ;
  1.  N SECTIONS D SECTIONS(TEST,.SECTIONS)  ; build SECTIONS(questionId)
  1.  N CTNTIDX S CTNTIDX=0                  ; content index - global scope
  1.  N LSTINTRO S LSTINTRO=0                ; last intro used
  1.  ;
  1.  ; loop thru content by sequence, then choices by sequence
  1.  N SEQ,CTNT,X0,X2,QSTN,DISP,RTYP,CTYP
  1.  S SEQ=0 F  S SEQ=$O(^YTT(601.76,"AD",TEST,SEQ)) Q:'SEQ  D
  1.  . S CTNT=0 F  S CTNT=$O(^YTT(601.76,"AD",TEST,SEQ,CTNT)) Q:'CTNT  D
  1.  . . S X0=^YTT(601.76,CTNT,0),QSTN=$P(X0,U,4),DISP=$P(X0,U,8)
  1.  . . S X2=^YTT(601.72,QSTN,2),RTYP=$P(X2,U,2),CTYP=$P(X2,U,3)
  1.  . . ; if section header and intro are both present, prepend section header
  1.  . . I +$P(X2,U)'=LSTINTRO S LSTINTRO=+$P(X2,U) D
  1.  . . . N SECTHDR S SECTHDR=""
  1.  . . . I $D(SECTIONS(QSTN)) S SECTHDR=$P(SECTIONS(QSTN),U,5)
  1.  . . . I $L(SECTHDR) S SECTHDR=SECTHDR_"<br />"
  1.  . . . D ADDINTRO(+$P(X2,U),$P(X0,U,7),SECTHDR)
  1.  . . E  D
  1.  . . . I $D(SECTIONS(QSTN)) D ADDSECT(SECTIONS(QSTN))
  1.  . . D ADDQSTN(QSTN,$P(X0,U,5),$P(X0,U,6))
  1.  . . ;
  1.  . . ; add additional properties based on response type
  1.  . . ; DISP is the MH DISPLAY entry for MHCHOICEDISPLAYID
  1.  . . ; (the entries for question and intro don't appear to do much)
  1.  . . I RTYP=1 D RADIO(QSTN,DISP,CTYP)
  1.  . . I RTYP=2 D SPIN(QSTN,DISP)
  1.  . . I RTYP=3 D TEXT(QSTN,DISP)
  1.  . . I RTYP=4 D DATE(QSTN,DISP)
  1.  . . I RTYP=5 D MEMO(QSTN,DISP)
  1.  . . I RTYP=7 D RANGE(QSTN,DISP,CTYP)
  1.  . . I RTYP=11 D CHECK(QSTN,DISP,CTYP)
  1.  Q
  1.  ;
  1.  ; -- for the control type entry points below --
  1.  ; expects CTNTIDX to be index of current question
  1.  ; QSTN: question id (file 601.72 ien)
  1.  ; CTYP: choice type (file 601.751 ien, multiple)
  1.  ; DISP: choice display id (file 601.88 ien)
  1.  ;
  1. RADIO(QSTN,DISP,CTYP) ; add properties for radio group (1 MCHOICE)
  1.  ; add choices, inline/columns
  1.  S TREE("content",CTNTIDX,"type")="ChoiceQuestion"
  1.  D CHLOOP(CTYP,1) ; 1=MCHOICE -- add choices
  1.  Q:'$G(DISP)  ; no choice level MH DISPAY ENTRY
  1.  N X0 S X0=$G(^YTT(601.88,DISP,0))
  1.  ; for now, make inline if columns > 1
  1.  S TREE("content",CTNTIDX,"inline")=$S($P(X0,U,11)>1:"true",1:"false")
  1.  I $P(X0,U,11) S TREE("content",CTNTIDX,"columns")=$P(X0,U,11)
  1.  ; I $P(X0,U,11)>2 W !,"Test:",TEST,"  Qstn:",QSTN,"  Cols:",$P(X0,U,11)
  1.  Q
  1. SPIN(QSTN,DISP) ; add properties for spin control (2 INTEGER)
  1.  ; add inline, default value, max, min
  1.  S TREE("content",CTNTIDX,"type")="IntegerQuestion"
  1.  D MINMAX(QSTN)
  1.  D MASK(DISP)
  1.  Q
  1. TEXT(QSTN,DISP) ; add properties for edit control (3 STRING)
  1.  ;inline, width, default value (mask), max, min
  1.  S TREE("content",CTNTIDX,"type")="StringQuestion"
  1.  D MINMAX(QSTN)
  1.  D MASK(DISP)
  1.  Q
  1. DATE(QSTN,DISP) ; add properties for date picker  (4 DATE)
  1.  ;add inline, default value
  1.  S TREE("content",CTNTIDX,"type")="DateQuestion"
  1.  D MASK(DISP)
  1.  Q
  1. MEMO(QSTN,DISP) ; add properties for memo control (5 MEMO)
  1.  ; add width, default value
  1.  S TREE("content",CTNTIDX,"type")="MemoQuestion"
  1.  D MASK(DISP)
  1.  Q
  1. RANGE(QSTN,DISP,CTYP) ; add properties for range/slider (7 TRACK BAR)
  1.  ;add min, max, legend (choices), {labels}
  1.  S TREE("content",CTNTIDX,"type")="SliderQuestion"
  1.  D MINMAX(QSTN)
  1.  D CHLOOP(CTYP,7) ; 7=TRACK BAR 
  1.  Q
  1. CHECK(QSTN,DISP,CTYP) ; add properties for check list  (11 CHECKLIST)
  1.  ; add choices, inline/columns
  1.  S TREE("content",CTNTIDX,"type")="CheckQuestion"
  1.  D CHLOOP(CTYP,11) ; 11=CHECKLIST
  1.  N X0 S X0=$G(^YTT(601.88,DISP,0))
  1.  ; for now, make inline if columns > 1
  1.  S TREE("content",CTNTIDX,"inline")=$S($P(X0,U,11)>1:"true",1:"false")
  1.  I $P(X0,U,11) S TREE("content",CTNTIDX,"columns")=$P(X0,U,11)
  1.  Q
  1.  ;
  1. MINMAX(QSTN) ; set max/min properties
  1.  N X2 S X2=$G(^YTT(601.72,QSTN,2))
  1.  I +$P(X2,U,4)=$P(X2,U,4) S TREE("content",CTNTIDX,"min")=+$P(X2,U,4)
  1.  I +$P(X2,U,5)=$P(X2,U,5) S TREE("content",CTNTIDX,"max")=+$P(X2,U,5)
  1.  Q
  1. MASK(DISP) ; set properties from |-delimited MASK field
  1.  Q:'DISP                     ; some instruments have no display pointer
  1.  Q:'$D(^YTT(601.88,DISP,0))  ; some instruments have broken pointers
  1.  N MASK S MASK=$P(^YTT(601.88,DISP,0),U,10)
  1.  I +MASK S TREE("content",CTNTIDX,"controlWidth")=+MASK
  1.  I $L($P(MASK,"|",2)) S TREE("content",CTNTIDX,"default")=$P(MASK,"|",2)
  1.  I $P(MASK,"|",3)="S" S TREE("content",CTNTIDX,"inline")="true"
  1.  Q
  1. CHLOOP(CTYP,CALL) ; loop through choices for a choice type
  1.  ; CTYP: Id for ChoiceTypes (601.751) and ChoiceIdentifier (601.89)
  1.  ; CALL: Code to call for building appropriate type of node
  1.  N CIDF,CSEQ,CHID,CIEN,CIDX
  1.  S CIDX=0,CIDF=$O(^YTT(601.89,"B",CTYP,0)) ; choice identifier ien
  1.  S CSEQ=0 F  S CSEQ=$O(^YTT(601.751,"AC",CTYP,CSEQ)) Q:'CSEQ  D
  1.  . S CHID=0 F  S CHID=$O(^YTT(601.751,"AC",CTYP,CSEQ,CHID)) Q:'CHID  D
  1.  . . S CIDX=CIDX+1
  1.  . . I CALL=1 D ADDCH(CIDX,CIDF,CHID) Q   ; radio buttons
  1.  . . I CALL=7 D ADDLGND(CIDX,CHID) Q      ; range control
  1.  . . I CALL=11 D ADDCH(CIDX,CIDF,CHID) Q  ; checklist
  1.  Q
  1. SECTIONS(TEST,SECTIONS) ; build list of sections for TEST
  1.  ; SECTIONS(questionIEN)=ID^TEST^Question^TabName^Header^Format
  1.  N IEN,X0
  1.  S IEN=0 F  S IEN=$O(^YTT(601.81,"AC",TEST,IEN)) Q:'IEN  D
  1.  . S X0=^YTT(601.81,IEN,0)
  1.  . S SECTIONS($P(X0,U,3))=X0
  1.  Q
  1. ADDSECT(X0) ; add section node
  1.  ; expects TREE, CTNTIDX from CONTENT
  1.  ; X0: ID^TEST^Question^TabName^Header^Format
  1.  S CTNTIDX=CTNTIDX+1
  1.  ; treat Section Header as Intro
  1.  I '$L($P(X0,U,5)) QUIT
  1.  S TREE("content",CTNTIDX,"id")="s"_+X0
  1.  S TREE("content",CTNTIDX,"type")="IntroText"
  1.  S TREE("content",CTNTIDX,"text")=$P(X0,U,5)
  1.  ; code was:
  1.  ; S TREE("content",CTNTIDX,"id")="s"_+X0
  1.  ; S TREE("content",CTNTIDX,"type")="Section"
  1.  ; I $L($P(X0,U,4)) S TREE("content",CTNTIDX,"tab")=$P(X0,U,4)
  1.  ; I $L($P(X0,U,5)) S TREE("content",CTNTIDX,"text")=$P(X0,U,5)
  1.  Q
  1. ADDINTRO(IEN,FORMAT,PREPEND) ; add intro node
  1.  ; expects TREE, CTNTIDX from CONTENT
  1.  Q:'IEN
  1.  N TEXT
  1.  S CTNTIDX=CTNTIDX+1
  1.  S TREE("content",CTNTIDX,"id")="i"_+^YTT(601.73,IEN,0)
  1.  S TREE("content",CTNTIDX,"type")="IntroText"
  1.  D BLDTXT^YTWJSONU($NA(^YTT(601.73,IEN,1)),.TEXT)
  1.  S TEXT=PREPEND_$G(TEXT) ; TEMPORARY fix of section header
  1.  M TREE("content",CTNTIDX,"text")=TEXT
  1.  Q
  1. ADDQSTN(IEN,DESIG,FORMAT) ; add question node
  1.  N TEXT,X0,X2,ITEXT
  1.  S CTNTIDX=CTNTIDX+1
  1.  S X0=^YTT(601.72,IEN,0),X2=$G(^(2))
  1.  I $L(DESIG),($E(DESIG,$L(DESIG))'=".") S DESIG=DESIG_"."
  1.  S TREE("content",CTNTIDX,"id")="q"_+X0
  1.  D BLDTXT^YTWJSONU($NA(^YTT(601.72,IEN,1)),.TEXT)
  1.  M TREE("content",CTNTIDX,"text")=TEXT
  1.  S TREE("content",CTNTIDX,"text")=DESIG_" "_TREE("content",CTNTIDX,"text")
  1.  S TREE("content",CTNTIDX,"required")=$S($P(X2,U,6)="Y":"true",1:"false")
  1.  I +X2 D
  1.  . D BLDTXT^YTWJSONU($NA(^YTT(601.73,+X2,1)),.ITEXT)
  1.  . M TREE("content",CTNTIDX,"intro")=ITEXT
  1.  ; add HINT? -- not currently used by any of the active instruments
  1.  Q
  1. ADDCH(INDEX,IDENTIEN,CHIEN) ; add choice node
  1.  ; child of current question, use current CTNTIDX
  1.  N IDBASE,NUM,QUICK
  1.  S TREE("content",CTNTIDX,"choices",INDEX,"id")="c"_+^YTT(601.75,CHIEN,0)
  1.  ; default IDBASE to 1 if no file entry for legacy tests
  1.  S IDBASE=$S('IDENTIEN:1,1:$P(^YTT(601.89,IDENTIEN,0),U,2))
  1.  S NUM=$S(IDBASE=0:INDEX-1,IDBASE=1:INDEX,1:"") S:$L(NUM) NUM=NUM_"."
  1.  S TREE("content",CTNTIDX,"choices",INDEX,"text")=NUM_" "_$$HTMLESC^YTWJSONU(^YTT(601.75,CHIEN,1))
  1.  S QUICK=$P(NUM,"."),QUICK=$S(+QUICK=QUICK:+QUICK,1:"") ;S:QUICK QUICK=QUICK+48
  1.  I $L(QUICK) S TREE("content",CTNTIDX,"choices",INDEX,"quickKey")=QUICK
  1.  Q
  1. ADDLGND(INDEX,CHIEN) ; add legend based on choices
  1.  S TREE("content",CTNTIDX,"legend",INDEX)=^YTT(601.75,CHIEN,1)
  1.  Q
  1. RULES(TEST,TREE) ; add RULES for TEST to spec TREE for JSON conversion
  1.  N IRID,RID,RIDX,X,X0,X1,QSTN1,QSTN2
  1.  S RIDX=0
  1.  S QSTN1=0 F  S QSTN1=$O(^YTT(601.83,"AD",TEST,QSTN1)) Q:'QSTN1  D
  1.  . S IRID=0 F  S IRID=$O(^YTT(601.83,"AD",TEST,QSTN1,IRID)) Q:'IRID  D
  1.  . . S RID=$P(^YTT(601.83,IRID,0),U,4),RIDX=RIDX+1
  1.  . . S X0=^YTT(601.82,RID,0),X1=$G(^(1)),X=$P(X0,U,5)
  1.  . . S TREE("rules",RIDX,"question")="q"_QSTN1
  1.  . . S TREE("rules",RIDX,"operator")=$S(X="Does not equal":"NE",X="Equals":"EQ",1:X)
  1.  . . S TREE("rules",RIDX,"value")=$$TRUTHVAL(QSTN1,$P(X0,U,3))
  1.  . . I $L(X1),$P(X0,U,6)="AND" D
  1.  . . . S QSTN2=$P(X0,U,7),X=$P(X1,U,3) Q:'QSTN2
  1.  . . . S TREE("rules",RIDX,"conjunction")="and"
  1.  . . . S TREE("rules",RIDX,"question2")="q"_QSTN2
  1.  . . . S TREE("rules",RIDX,"operator2")=$S(X="Does not equal":"NE",X="Equals":"EQ",1:X)
  1.  . . . S TREE("rules",RIDX,"value2")=$$TRUTHVAL(QSTN2,$P(X1,U,1))
  1.  . . D SETSKIPS(RID,RIDX)
  1.  Q
  1. TRUTHVAL(QSTN,VALUE) ; return the target value for the rule
  1.  ; if MCHOICE, convert from Delphi itemIndex value to choice id
  1.  I $P($G(^YTT(601.72,QSTN,2)),U,2)'=1 Q VALUE  ; not MCHOICE so return value
  1.  N CTYP,CSEQ,CHID,IDX,DONE                     ; otherwise, find choice id
  1.  S CTYP=$P($G(^YTT(601.72,QSTN,2)),U,3),(CSEQ,CHID,DONE,IDX)=0
  1.  F  S CSEQ=$O(^YTT(601.751,"AC",CTYP,CSEQ)) Q:'CSEQ  D  Q:DONE 
  1.  . I IDX=VALUE S CHID=$O(^YTT(601.751,"AC",CTYP,CSEQ,CHID)),DONE=1 Q
  1.  . S IDX=IDX+1
  1.  Q "c"_CHID
  1.  ;
  1. SETSKIPS(RID,RIDX) ; set skipped questions for rule RID at index RIDX
  1.  N SID,QID,SIDX
  1.  S SIDX=0
  1.  S SID=0 F  S SID=$O(^YTT(601.79,"AE",RID,SID)) Q:'SID  D
  1.  . S QID=$P(^YTT(601.79,SID,0),U,4) Q:'QID
  1.  . S SIDX=SIDX+1
  1.  . S TREE("rules",RIDX,"skips",SIDX)="q"_QID
  1.  Q