YTXCHG ;SLC/KCM - Instrument Exchange Calls ; 9/15/2015
;;5.01;MENTAL HEALTH;**121,123,130,218**;Dec 30, 1994;Build 9
;
; Reference to %ZISH in ICR #2320
; Reference to DIC in ICR #2051
; Reference to DIK in ICR #10013
; Reference to XPDUTL in ICR #10141
; Reference to XTHC10 in ICR #5515
;
VERSION ;; current Instrument Exchange version
;;1.02
Q
INCLUDE(Y,TAG,RTN) ; return true for Y in list produced by TAG^RTN
; Y: IEN of entry currently being checked for inclusion
; TAG^RTN(.ARRAY) is called to build list of 601.95 entries in ARRAY
; .ARRAY(n,1): name (.01) value in 601.95
; .ARRAY(n,2): date (.02) value in 601.95
;
N ARRAY,IDX,FOUND,VALS,IEN
D @(TAG_U_RTN_"(.ARRAY)")
S FOUND=0
S IDX=0 F S IDX=$O(ARRAY(IDX)) Q:'IDX D Q:FOUND
. M VALS=ARRAY(IDX)
. S IEN=+$$FIND1^DIC(601.95,"","KU",.VALS)
. I IEN=Y S FOUND=1
Q FOUND
;
CREATE(TESTS,XCHGREC) ; return IEN or error after creating exchange entry
; .TESTS(n)=instrumentIEN ; instruments to include in JSON spec
; .XCHGREC(field)=value ; values used to create exchange entry
N SEQ,XCHGIEN,OK
K ^TMP("YTXCHGE",$J,"TREE")
K ^TMP("YTXCHGE",$J,"JSON")
S SEQ=0 F S SEQ=$O(TESTS(SEQ)) Q:'SEQ D
. D MHA2TR^YTXCHGT(TESTS(SEQ),$NA(^TMP("YTXCHGE",$J,"TREE","test",SEQ)))
S ^TMP("YTXCHGE",$J,"TREE","xchg","name")=XCHGREC(.01)
S ^TMP("YTXCHGE",$J,"TREE","xchg","date")=XCHGREC(.02)
S ^TMP("YTXCHGE",$J,"TREE","xchg","source")=XCHGREC(.03)
S ^TMP("YTXCHGE",$J,"TREE","xchg","version")=+$P($T(VERSION+1),";;",2)
D WP2TR^YTXCHGT(XCHGREC(2),$NA(^TMP("YTXCHGE",$J,"TREE","xchg","description")))
S OK=$$TR2JSON^YTXCHGT($NA(^TMP("YTXCHGE",$J,"TREE")),$NA(^TMP("YTXCHGE",$J,"JSON")))
S XCHGREC(1)=$NA(^TMP("YTXCHGE",$J,"JSON"))
I OK D FMADD^YTXCHGU(601.95,.XCHGREC,.XCHGIEN)
K ^TMP("YTXCHGE",$J,"TREE")
K ^TMP("YTXCHGE",$J,"JSON")
Q $S(OK:XCHGIEN,1:-1)
;
INFO(XCHGIEN,INFO) ; put build information into .INFO
; .INFO(fld)=value
; .INFO("tests",n)=testName
I $D(^YTT(601.95,XCHGIEN,1))'>1 D LOG^YTXCHGU("error","Spec not found.") Q
N I,OK
K ^TMP("YTXCHG",$J,"TREE")
S OK=$$SPEC2TR^YTXCHGT(XCHGIEN,$NA(^TMP("YTXCHG",$J,"TREE"))) G:'OK XINFO
I $D(^YTT(601.95,XCHGIEN,4,1,0)) D ; pull in addendum if it is there
. D WP2TR^YTXCHGT($NA(^YTT(601.95,XCHGIEN,4)),$NA(^TMP("YTXCHG",$J,"TREE","xchg","addendum")))
S I=0 F S I=$O(^TMP("YTXCHG",$J,"TREE","test",I)) Q:'I D
. S INFO("tests",I)=^TMP("YTXCHG",$J,"TREE","test",I,"info","name")
D SETINFO(.INFO,$NA(^TMP("YTXCHG",$J,"TREE")))
XINFO ; exit here
K ^TMP("YTXCHG",$J,"TREE")
Q
DELETE(XCHGIEN) ; delete instrument exchange entry
N DIK,DA
I '$D(^YTT(601.95,XCHGIEN)) D LOG^YTXCHGU("error","Entry not found.") Q
S DIK="^YTT(601.95,",DA=XCHGIEN
D ^DIK
Q
INSTALL(XCHGIEN,DRYRUN) ; install instrument exchange entry locally
I $D(^YTT(601.95,XCHGIEN,1))'>1 D LOG^YTXCHGU("error","Install entry #"_XCHGIEN_" not found.") QUIT
;
; set up index across MH files
I $P($G(^XTMP("YTXIDX",0)),U,2)'=DT D IDXALL^YTXCHGV
I $P($G(^XTMP("YTXIDX",0)),U,2)'=DT D LOG^YTXCHGU("error","Unable to index") QUIT
;
K ^TMP("YTXCHGI",$J,"TREE")
N OK
S OK=$$SPEC2TR^YTXCHGT(XCHGIEN,$NA(^TMP("YTXCHGI",$J,"TREE")))
I OK D
. I $$BADVER($G(^TMP("YTXCHGI",$J,"TREE","xchg","version"))) QUIT
. D TR2MHA^YTXCHGT($NA(^TMP("YTXCHGI",$J,"TREE")),$G(DRYRUN))
. I '$G(DRYRUN) D
. . D LOGINST^YTXCHGU(XCHGIEN)
. . D CHKSCORE^YTXCHGT(XCHGIEN)
. . D LIST96^YTWJSONF ; rebuild active instrument list
K ^TMP("YTXCHGI",$J,"TREE")
Q
INSTALLQ(TAG,RTN) ; install exchange entries listed by TAG^RTN in post-init
; TAG^RTN(.ARRAY) is called to build list of 601.95 entries in ARRAY
; .ARRAY(n,1): name (.01) value in 601.95
; .ARRAY(n,2): date (.02) value in 601.95
N ARRAY,XCHGI,VALS,XCHGIEN
D @(TAG_U_RTN_"(.ARRAY)")
S XCHGI=0 F S XCHGI=$O(ARRAY(XCHGI)) Q:'XCHGI D
. M VALS=ARRAY(XCHGI)
. S XCHGIEN=+$$FIND1^DIC(601.95,"","KU",.VALS)
. Q:'XCHGIEN
. D INSTALL(XCHGIEN)
. ; D FMDEL^YTXCHGU(601.95,XCHGIEN) ; remove now that install is done
D BMES^XPDUTL("MH Instrument install complete.")
Q
BADVER(VERSION) ; return true if version conflict
I VERSION'=+$P($T(VERSION+1),";;",2) D QUIT 1
. D LOG^YTXCHGU("error","Version conflict, unable to continue.")
Q 0
;
BLDVIEW(TREE,DEST) ; create array for BROWSER view
; TREE: $NA global reference for the instrument node of the tree
; DEST: $NA global reference for the output lines
N MAP,IDX,CNTLINE,CNTROOT
S IDX=0,CNTLINE=0,CNTROOT=$QL(TREE)
D BLDSEQ^YTXCHGM(.MAP)
D ITER("MAP")
Q
ITER(MAPREF) ;
; expects IDX where IDX(IDX) is current index
; MAPREF: $NA for the current reference in the map of JSON labels
N NODE,SEQ,LABEL
;I $QS(MAPREF,4)="choiceIdentifier" B
I $D(@MAPREF)=1 S NODE=$$TREEREF(MAPREF,.IDX) D LINEOUT(NODE) QUIT
;
S IDX=IDX+1,IDX(IDX)=0
S SEQ=0 F S SEQ=$O(@MAPREF@(SEQ)) Q:'SEQ D
. S LABEL=$O(@MAPREF@(SEQ,""))
. I $E(LABEL)="?" D Q ; iterate thru tree and call iter with varying ref
. . S NODE=$$TREEREF($NA(@MAPREF@(SEQ,LABEL)),.IDX)
. . F S IDX(IDX)=$O(@NODE@(IDX(IDX))) Q:'IDX(IDX) D ITER($NA(@MAPREF@(SEQ,LABEL)))
. E D ITER($NA(@MAPREF@(SEQ,LABEL))) ; call iter with next label
S IDX=IDX-1
Q
TREEREF(MAPREF,IDX) ; return reference to data tree given map reference
; expects TREE from BLDVIEW for root tree reference
N LEVEL,RESULT,I,LABEL
S LEVEL=0,RESULT=""
F I=2:2:$QL(MAPREF) S LABEL=$QS(MAPREF,I) D
. S LEVEL=LEVEL+1
. I $L(RESULT) S RESULT=RESULT_","
. I $E(LABEL)="?" D Q
. . S RESULT=RESULT_""""_$E(LABEL,2,$L(LABEL))_""""
. . I LEVEL<IDX S RESULT=RESULT_","_IDX(LEVEL)
. S RESULT=RESULT_""""_LABEL_""""
S RESULT=$E(TREE,1,$L(TREE)-1)_","_RESULT_")"
Q RESULT
;
LINEOUT(NODE) ; add output line
; expects CNTROOT,CNTLINE,DEST from BLDVIEW
Q:'$L($G(@NODE))
I $QS(NODE,CNTROOT+2)="template" D TLTOUT(NODE) QUIT
N LINE,I,SUB
S LINE=""
F I=CNTROOT+1:1:($QL(NODE)) S SUB=$QS(NODE,I) D
. I +SUB,(+SUB=SUB) S SUB="["_SUB_"]" I 1
. E S:$L(LINE) LINE=LINE_"."
. S LINE=LINE_SUB
S CNTLINE=CNTLINE+1,@DEST@(CNTLINE,0)=LINE_"="_@NODE
Q
TLTOUT(NODE) ; output the report template
; expects CNTLINE,DEST from BLDVIEW
Q:'$L($G(@NODE))
;
K ^TMP("YTXCHG",$J,"TEMPLATE")
D TR2WP^YTXCHGT(NODE,$NA(^TMP("YTXCHG",$J,"TEMPLATE")))
S CNTLINE=CNTLINE+1,@DEST@(CNTLINE,0)="report.template="
S CNTLINE=CNTLINE+1
N I,J,X
S I=0 F S I=$O(^TMP("YTXCHG",$J,"TEMPLATE",I)) Q:'I D
. S X=^TMP("YTXCHG",$J,"TEMPLATE",I,0)
. F J=1:1:$L(X,"|") D
. . I J=1 S @DEST@(CNTLINE,0)=$G(@DEST@(CNTLINE,0))_$P(X,"|",1) I 1
. . E S CNTLINE=CNTLINE+1,@DEST@(CNTLINE,0)=$P(X,"|",J)
K ^TMP("YTXCHG",$J,"TEMPLATE")
Q
SAVEHFS(XCHGIEN,FULLNM) ; save instrument exchange entry to host file
; return 1 if successful, otherwise 0
N SPECLOC,PATH,FILE,OK
S SPECLOC=$NA(^YTT(601.95,XCHGIEN,1,1,0))
I $D(^YTT(601.95,XCHGIEN,4,1,0)) D ; insert addendum into spec
. K ^TMP("YTXCHG",$J,"TREE"),^TMP("YTXCHG",$J,"JSON")
. S OK=$$SPEC2TR^YTXCHGT(XCHGIEN,$NA(^TMP("YTXCHG",$J,"TREE")))
. D WP2TR^YTXCHGT($NA(^YTT(601.95,XCHGIEN,4)),$NA(^TMP("YTXCHG",$J,"TREE","xchg","addendum")))
. S OK=$$TR2JSON^YTXCHGT($NA(^TMP("YTXCHG",$J,"TREE")),$NA(^TMP("YTXCHG",$J,"JSON")))
. S SPECLOC=$NA(^TMP("YTXCHG",$J,"JSON",1))
;
D SPLTDIR^YTXCHGU(FULLNM,.PATH,.FILE)
S OK=$$GTF^%ZISH(SPECLOC,4,PATH,FILE)
Q OK
;
LOADFILE(PATH,INFO) ; load file into JSON & tree structures
; PATH is full HFS name or URL
; .INFO returns the fields for 601.95 entry
; word processing values are in ^TMP("YTXCHG",$J,"WP",field)
; Specification ends up in ^TMP("YTXCHG",$J,"WP",1)
; Description content ends up in ^TMP("YTXCHG",$J,"WP",2)
K ^TMP("YTXCHG",$J,"JSON")
K ^TMP("YTXCHG",$J,"TREE")
K ^TMP("YTXCHG",$J,"WP",1),^TMP("YTXCHG",$J,"WP",2),^TMP("YTXCHG",$J,"WP",4)
I $E(PATH,1,4)="http" D LOADURL(PATH,.INFO) I 1 ; load file from URL
E D LOADHFS(PATH,.INFO) ; load file from HFS
Q:$G(INFO)=-1
N OK
S OK=$$JSON2TR^YTXCHGT($NA(^TMP("YTXCHG",$J,"JSON")),$NA(^TMP("YTXCHG",$J,"TREE")))
I 'OK S INFO=-1 G XLOADF
D SETINFO(.INFO,$NA(^TMP("YTXCHG",$J,"TREE")))
S INFO(1)=$NA(^TMP("YTXCHG",$J,"WP",1)) ; #1 is specification field
D JSON2WP^YTXCHGT($NA(^TMP("YTXCHG",$J,"JSON")),$NA(^TMP("YTXCHG",$J,"WP",1)))
XLOADF ; exit LOADFILE here
; ^TMP("YTXCHG",$J,"WP) should be cleaned up by caller
K ^TMP("YTXCHG",$J,"JSON")
K ^TMP("YTXCHG",$J,"TREE")
Q
LOADHFS(FULLNM,INFO) ; load file from HFS into JSON & tree structures
N DIR,FILE,OK
D SPLTDIR^YTXCHGU(FULLNM,.DIR,.FILE)
S OK=$$FTG^%ZISH(DIR,FILE,$NA(^TMP("YTXCHG",$J,"JSON",1)),4)
I 'OK D LOG^YTXCHGU("error","Failed to load "_FULLNM) S INFO=-1 QUIT
Q
LOADURL(URL,INFO) ; load file from URL into JSON & tree structures
N RESULT,HEADER
S RESULT=$$GETURL^XTHC10(URL,10,$NA(^TMP("YTXCHG",$J,"JSON")),.HEADER)
I $P(RESULT,U,1)'=200 D QUIT
. D LOG^YTXCHGU("error","Could not load file: "_$P(RESULT,U,1)_" "_$P(RESULT,U,2))
. S INFO=-1
Q
SETINFO(INFO,TREE) ; set .INFO array from specification TREE
S INFO(.01)=$G(@TREE@("xchg","name"))
S INFO(.02)=$G(@TREE@("xchg","date"))
S INFO(.03)=$G(@TREE@("xchg","source"))
S INFO(2)=$NA(^TMP("YTXCHG",$J,"WP",2)) ; #2 is description field
D TR2WP^YTXCHGT($NA(@TREE@("xchg","description")),INFO(2))
I '$D(@TREE@("xchg","addendum")) QUIT
S INFO(4)=$NA(^TMP("YTXCHG",$J,"WP",4)) ; #4 is addendum field
D TR2WP^YTXCHGT($NA(@TREE@("xchg","addendum")),INFO(4))
K @TREE@("xchg","addendum") ; remove so not included in spec
Q
SENDMAIL ; interactive -- send instrument exchange entry in mail message
Q
LOADMAIL ; interactive -- load instrument exchange entry from mail message
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHG 9798 printed Jun 11, 2024@22:04:50 Page 2
YTXCHG ;SLC/KCM - Instrument Exchange Calls ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121,123,130,218**;Dec 30, 1994;Build 9
+2 ;
+3 ; Reference to %ZISH in ICR #2320
+4 ; Reference to DIC in ICR #2051
+5 ; Reference to DIK in ICR #10013
+6 ; Reference to XPDUTL in ICR #10141
+7 ; Reference to XTHC10 in ICR #5515
+8 ;
VERSION ;; current Instrument Exchange version
+1 ;;1.02
+2 QUIT
INCLUDE(Y,TAG,RTN) ; return true for Y in list produced by TAG^RTN
+1 ; Y: IEN of entry currently being checked for inclusion
+2 ; TAG^RTN(.ARRAY) is called to build list of 601.95 entries in ARRAY
+3 ; .ARRAY(n,1): name (.01) value in 601.95
+4 ; .ARRAY(n,2): date (.02) value in 601.95
+5 ;
+6 NEW ARRAY,IDX,FOUND,VALS,IEN
+7 DO @(TAG_U_RTN_"(.ARRAY)")
+8 SET FOUND=0
+9 SET IDX=0
FOR
SET IDX=$ORDER(ARRAY(IDX))
if 'IDX
QUIT
Begin DoDot:1
+10 MERGE VALS=ARRAY(IDX)
+11 SET IEN=+$$FIND1^DIC(601.95,"","KU",.VALS)
+12 IF IEN=Y
SET FOUND=1
End DoDot:1
if FOUND
QUIT
+13 QUIT FOUND
+14 ;
CREATE(TESTS,XCHGREC) ; return IEN or error after creating exchange entry
+1 ; .TESTS(n)=instrumentIEN ; instruments to include in JSON spec
+2 ; .XCHGREC(field)=value ; values used to create exchange entry
+3 NEW SEQ,XCHGIEN,OK
+4 KILL ^TMP("YTXCHGE",$JOB,"TREE")
+5 KILL ^TMP("YTXCHGE",$JOB,"JSON")
+6 SET SEQ=0
FOR
SET SEQ=$ORDER(TESTS(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+7 DO MHA2TR^YTXCHGT(TESTS(SEQ),$NAME(^TMP("YTXCHGE",$JOB,"TREE","test",SEQ)))
End DoDot:1
+8 SET ^TMP("YTXCHGE",$JOB,"TREE","xchg","name")=XCHGREC(.01)
+9 SET ^TMP("YTXCHGE",$JOB,"TREE","xchg","date")=XCHGREC(.02)
+10 SET ^TMP("YTXCHGE",$JOB,"TREE","xchg","source")=XCHGREC(.03)
+11 SET ^TMP("YTXCHGE",$JOB,"TREE","xchg","version")=+$PIECE($TEXT(VERSION+1),";;",2)
+12 DO WP2TR^YTXCHGT(XCHGREC(2),$NAME(^TMP("YTXCHGE",$JOB,"TREE","xchg","description")))
+13 SET OK=$$TR2JSON^YTXCHGT($NAME(^TMP("YTXCHGE",$JOB,"TREE")),$NAME(^TMP("YTXCHGE",$JOB,"JSON")))
+14 SET XCHGREC(1)=$NAME(^TMP("YTXCHGE",$JOB,"JSON"))
+15 IF OK
DO FMADD^YTXCHGU(601.95,.XCHGREC,.XCHGIEN)
+16 KILL ^TMP("YTXCHGE",$JOB,"TREE")
+17 KILL ^TMP("YTXCHGE",$JOB,"JSON")
+18 QUIT $SELECT(OK:XCHGIEN,1:-1)
+19 ;
INFO(XCHGIEN,INFO) ; put build information into .INFO
+1 ; .INFO(fld)=value
+2 ; .INFO("tests",n)=testName
+3 IF $DATA(^YTT(601.95,XCHGIEN,1))'>1
DO LOG^YTXCHGU("error","Spec not found.")
QUIT
+4 NEW I,OK
+5 KILL ^TMP("YTXCHG",$JOB,"TREE")
+6 SET OK=$$SPEC2TR^YTXCHGT(XCHGIEN,$NAME(^TMP("YTXCHG",$JOB,"TREE")))
if 'OK
GOTO XINFO
+7 ; pull in addendum if it is there
IF $DATA(^YTT(601.95,XCHGIEN,4,1,0))
Begin DoDot:1
+8 DO WP2TR^YTXCHGT($NAME(^YTT(601.95,XCHGIEN,4)),$NAME(^TMP("YTXCHG",$JOB,"TREE","xchg","addendum")))
End DoDot:1
+9 SET I=0
FOR
SET I=$ORDER(^TMP("YTXCHG",$JOB,"TREE","test",I))
if 'I
QUIT
Begin DoDot:1
+10 SET INFO("tests",I)=^TMP("YTXCHG",$JOB,"TREE","test",I,"info","name")
End DoDot:1
+11 DO SETINFO(.INFO,$NAME(^TMP("YTXCHG",$JOB,"TREE")))
XINFO ; exit here
+1 KILL ^TMP("YTXCHG",$JOB,"TREE")
+2 QUIT
DELETE(XCHGIEN) ; delete instrument exchange entry
+1 NEW DIK,DA
+2 IF '$DATA(^YTT(601.95,XCHGIEN))
DO LOG^YTXCHGU("error","Entry not found.")
QUIT
+3 SET DIK="^YTT(601.95,"
SET DA=XCHGIEN
+4 DO ^DIK
+5 QUIT
INSTALL(XCHGIEN,DRYRUN) ; install instrument exchange entry locally
+1 IF $DATA(^YTT(601.95,XCHGIEN,1))'>1
DO LOG^YTXCHGU("error","Install entry #"_XCHGIEN_" not found.")
QUIT
+2 ;
+3 ; set up index across MH files
+4 IF $PIECE($GET(^XTMP("YTXIDX",0)),U,2)'=DT
DO IDXALL^YTXCHGV
+5 IF $PIECE($GET(^XTMP("YTXIDX",0)),U,2)'=DT
DO LOG^YTXCHGU("error","Unable to index")
QUIT
+6 ;
+7 KILL ^TMP("YTXCHGI",$JOB,"TREE")
+8 NEW OK
+9 SET OK=$$SPEC2TR^YTXCHGT(XCHGIEN,$NAME(^TMP("YTXCHGI",$JOB,"TREE")))
+10 IF OK
Begin DoDot:1
+11 IF $$BADVER($GET(^TMP("YTXCHGI",$JOB,"TREE","xchg","version")))
QUIT
+12 DO TR2MHA^YTXCHGT($NAME(^TMP("YTXCHGI",$JOB,"TREE")),$GET(DRYRUN))
+13 IF '$GET(DRYRUN)
Begin DoDot:2
+14 DO LOGINST^YTXCHGU(XCHGIEN)
+15 DO CHKSCORE^YTXCHGT(XCHGIEN)
+16 ; rebuild active instrument list
DO LIST96^YTWJSONF
End DoDot:2
End DoDot:1
+17 KILL ^TMP("YTXCHGI",$JOB,"TREE")
+18 QUIT
INSTALLQ(TAG,RTN) ; install exchange entries listed by TAG^RTN in post-init
+1 ; TAG^RTN(.ARRAY) is called to build list of 601.95 entries in ARRAY
+2 ; .ARRAY(n,1): name (.01) value in 601.95
+3 ; .ARRAY(n,2): date (.02) value in 601.95
+4 NEW ARRAY,XCHGI,VALS,XCHGIEN
+5 DO @(TAG_U_RTN_"(.ARRAY)")
+6 SET XCHGI=0
FOR
SET XCHGI=$ORDER(ARRAY(XCHGI))
if 'XCHGI
QUIT
Begin DoDot:1
+7 MERGE VALS=ARRAY(XCHGI)
+8 SET XCHGIEN=+$$FIND1^DIC(601.95,"","KU",.VALS)
+9 if 'XCHGIEN
QUIT
+10 DO INSTALL(XCHGIEN)
+11 ; D FMDEL^YTXCHGU(601.95,XCHGIEN) ; remove now that install is done
End DoDot:1
+12 DO BMES^XPDUTL("MH Instrument install complete.")
+13 QUIT
BADVER(VERSION) ; return true if version conflict
+1 IF VERSION'=+$PIECE($TEXT(VERSION+1),";;",2)
Begin DoDot:1
+2 DO LOG^YTXCHGU("error","Version conflict, unable to continue.")
End DoDot:1
QUIT 1
+3 QUIT 0
+4 ;
BLDVIEW(TREE,DEST) ; create array for BROWSER view
+1 ; TREE: $NA global reference for the instrument node of the tree
+2 ; DEST: $NA global reference for the output lines
+3 NEW MAP,IDX,CNTLINE,CNTROOT
+4 SET IDX=0
SET CNTLINE=0
SET CNTROOT=$QLENGTH(TREE)
+5 DO BLDSEQ^YTXCHGM(.MAP)
+6 DO ITER("MAP")
+7 QUIT
ITER(MAPREF) ;
+1 ; expects IDX where IDX(IDX) is current index
+2 ; MAPREF: $NA for the current reference in the map of JSON labels
+3 NEW NODE,SEQ,LABEL
+4 ;I $QS(MAPREF,4)="choiceIdentifier" B
+5 IF $DATA(@MAPREF)=1
SET NODE=$$TREEREF(MAPREF,.IDX)
DO LINEOUT(NODE)
QUIT
+6 ;
+7 SET IDX=IDX+1
SET IDX(IDX)=0
+8 SET SEQ=0
FOR
SET SEQ=$ORDER(@MAPREF@(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+9 SET LABEL=$ORDER(@MAPREF@(SEQ,""))
+10 ; iterate thru tree and call iter with varying ref
IF $EXTRACT(LABEL)="?"
Begin DoDot:2
+11 SET NODE=$$TREEREF($NAME(@MAPREF@(SEQ,LABEL)),.IDX)
+12 FOR
SET IDX(IDX)=$ORDER(@NODE@(IDX(IDX)))
if 'IDX(IDX)
QUIT
DO ITER($NAME(@MAPREF@(SEQ,LABEL)))
End DoDot:2
QUIT
+13 ; call iter with next label
IF '$TEST
DO ITER($NAME(@MAPREF@(SEQ,LABEL)))
End DoDot:1
+14 SET IDX=IDX-1
+15 QUIT
TREEREF(MAPREF,IDX) ; return reference to data tree given map reference
+1 ; expects TREE from BLDVIEW for root tree reference
+2 NEW LEVEL,RESULT,I,LABEL
+3 SET LEVEL=0
SET RESULT=""
+4 FOR I=2:2:$QLENGTH(MAPREF)
SET LABEL=$QSUBSCRIPT(MAPREF,I)
Begin DoDot:1
+5 SET LEVEL=LEVEL+1
+6 IF $LENGTH(RESULT)
SET RESULT=RESULT_","
+7 IF $EXTRACT(LABEL)="?"
Begin DoDot:2
+8 SET RESULT=RESULT_""""_$EXTRACT(LABEL,2,$LENGTH(LABEL))_""""
+9 IF LEVEL<IDX
SET RESULT=RESULT_","_IDX(LEVEL)
End DoDot:2
QUIT
+10 SET RESULT=RESULT_""""_LABEL_""""
End DoDot:1
+11 SET RESULT=$EXTRACT(TREE,1,$LENGTH(TREE)-1)_","_RESULT_")"
+12 QUIT RESULT
+13 ;
LINEOUT(NODE) ; add output line
+1 ; expects CNTROOT,CNTLINE,DEST from BLDVIEW
+2 if '$LENGTH($GET(@NODE))
QUIT
+3 IF $QSUBSCRIPT(NODE,CNTROOT+2)="template"
DO TLTOUT(NODE)
QUIT
+4 NEW LINE,I,SUB
+5 SET LINE=""
+6 FOR I=CNTROOT+1:1:($QLENGTH(NODE))
SET SUB=$QSUBSCRIPT(NODE,I)
Begin DoDot:1
+7 IF +SUB
IF (+SUB=SUB)
SET SUB="["_SUB_"]"
IF 1
+8 IF '$TEST
if $LENGTH(LINE)
SET LINE=LINE_"."
+9 SET LINE=LINE_SUB
End DoDot:1
+10 SET CNTLINE=CNTLINE+1
SET @DEST@(CNTLINE,0)=LINE_"="_@NODE
+11 QUIT
TLTOUT(NODE) ; output the report template
+1 ; expects CNTLINE,DEST from BLDVIEW
+2 if '$LENGTH($GET(@NODE))
QUIT
+3 ;
+4 KILL ^TMP("YTXCHG",$JOB,"TEMPLATE")
+5 DO TR2WP^YTXCHGT(NODE,$NAME(^TMP("YTXCHG",$JOB,"TEMPLATE")))
+6 SET CNTLINE=CNTLINE+1
SET @DEST@(CNTLINE,0)="report.template="
+7 SET CNTLINE=CNTLINE+1
+8 NEW I,J,X
+9 SET I=0
FOR
SET I=$ORDER(^TMP("YTXCHG",$JOB,"TEMPLATE",I))
if 'I
QUIT
Begin DoDot:1
+10 SET X=^TMP("YTXCHG",$JOB,"TEMPLATE",I,0)
+11 FOR J=1:1:$LENGTH(X,"|")
Begin DoDot:2
+12 IF J=1
SET @DEST@(CNTLINE,0)=$GET(@DEST@(CNTLINE,0))_$PIECE(X,"|",1)
IF 1
+13 IF '$TEST
SET CNTLINE=CNTLINE+1
SET @DEST@(CNTLINE,0)=$PIECE(X,"|",J)
End DoDot:2
End DoDot:1
+14 KILL ^TMP("YTXCHG",$JOB,"TEMPLATE")
+15 QUIT
SAVEHFS(XCHGIEN,FULLNM) ; save instrument exchange entry to host file
+1 ; return 1 if successful, otherwise 0
+2 NEW SPECLOC,PATH,FILE,OK
+3 SET SPECLOC=$NAME(^YTT(601.95,XCHGIEN,1,1,0))
+4 ; insert addendum into spec
IF $DATA(^YTT(601.95,XCHGIEN,4,1,0))
Begin DoDot:1
+5 KILL ^TMP("YTXCHG",$JOB,"TREE"),^TMP("YTXCHG",$JOB,"JSON")
+6 SET OK=$$SPEC2TR^YTXCHGT(XCHGIEN,$NAME(^TMP("YTXCHG",$JOB,"TREE")))
+7 DO WP2TR^YTXCHGT($NAME(^YTT(601.95,XCHGIEN,4)),$NAME(^TMP("YTXCHG",$JOB,"TREE","xchg","addendum")))
+8 SET OK=$$TR2JSON^YTXCHGT($NAME(^TMP("YTXCHG",$JOB,"TREE")),$NAME(^TMP("YTXCHG",$JOB,"JSON")))
+9 SET SPECLOC=$NAME(^TMP("YTXCHG",$JOB,"JSON",1))
End DoDot:1
+10 ;
+11 DO SPLTDIR^YTXCHGU(FULLNM,.PATH,.FILE)
+12 SET OK=$$GTF^%ZISH(SPECLOC,4,PATH,FILE)
+13 QUIT OK
+14 ;
LOADFILE(PATH,INFO) ; load file into JSON & tree structures
+1 ; PATH is full HFS name or URL
+2 ; .INFO returns the fields for 601.95 entry
+3 ; word processing values are in ^TMP("YTXCHG",$J,"WP",field)
+4 ; Specification ends up in ^TMP("YTXCHG",$J,"WP",1)
+5 ; Description content ends up in ^TMP("YTXCHG",$J,"WP",2)
+6 KILL ^TMP("YTXCHG",$JOB,"JSON")
+7 KILL ^TMP("YTXCHG",$JOB,"TREE")
+8 KILL ^TMP("YTXCHG",$JOB,"WP",1),^TMP("YTXCHG",$JOB,"WP",2),^TMP("YTXCHG",$JOB,"WP",4)
+9 ; load file from URL
IF $EXTRACT(PATH,1,4)="http"
DO LOADURL(PATH,.INFO)
IF 1
+10 ; load file from HFS
IF '$TEST
DO LOADHFS(PATH,.INFO)
+11 if $GET(INFO)=-1
QUIT
+12 NEW OK
+13 SET OK=$$JSON2TR^YTXCHGT($NAME(^TMP("YTXCHG",$JOB,"JSON")),$NAME(^TMP("YTXCHG",$JOB,"TREE")))
+14 IF 'OK
SET INFO=-1
GOTO XLOADF
+15 DO SETINFO(.INFO,$NAME(^TMP("YTXCHG",$JOB,"TREE")))
+16 ; #1 is specification field
SET INFO(1)=$NAME(^TMP("YTXCHG",$JOB,"WP",1))
+17 DO JSON2WP^YTXCHGT($NAME(^TMP("YTXCHG",$JOB,"JSON")),$NAME(^TMP("YTXCHG",$JOB,"WP",1)))
XLOADF ; exit LOADFILE here
+1 ; ^TMP("YTXCHG",$J,"WP) should be cleaned up by caller
+2 KILL ^TMP("YTXCHG",$JOB,"JSON")
+3 KILL ^TMP("YTXCHG",$JOB,"TREE")
+4 QUIT
LOADHFS(FULLNM,INFO) ; load file from HFS into JSON & tree structures
+1 NEW DIR,FILE,OK
+2 DO SPLTDIR^YTXCHGU(FULLNM,.DIR,.FILE)
+3 SET OK=$$FTG^%ZISH(DIR,FILE,$NAME(^TMP("YTXCHG",$JOB,"JSON",1)),4)
+4 IF 'OK
DO LOG^YTXCHGU("error","Failed to load "_FULLNM)
SET INFO=-1
QUIT
+5 QUIT
LOADURL(URL,INFO) ; load file from URL into JSON & tree structures
+1 NEW RESULT,HEADER
+2 SET RESULT=$$GETURL^XTHC10(URL,10,$NAME(^TMP("YTXCHG",$JOB,"JSON")),.HEADER)
+3 IF $PIECE(RESULT,U,1)'=200
Begin DoDot:1
+4 DO LOG^YTXCHGU("error","Could not load file: "_$PIECE(RESULT,U,1)_" "_$PIECE(RESULT,U,2))
+5 SET INFO=-1
End DoDot:1
QUIT
+6 QUIT
SETINFO(INFO,TREE) ; set .INFO array from specification TREE
+1 SET INFO(.01)=$GET(@TREE@("xchg","name"))
+2 SET INFO(.02)=$GET(@TREE@("xchg","date"))
+3 SET INFO(.03)=$GET(@TREE@("xchg","source"))
+4 ; #2 is description field
SET INFO(2)=$NAME(^TMP("YTXCHG",$JOB,"WP",2))
+5 DO TR2WP^YTXCHGT($NAME(@TREE@("xchg","description")),INFO(2))
+6 IF '$DATA(@TREE@("xchg","addendum"))
QUIT
+7 ; #4 is addendum field
SET INFO(4)=$NAME(^TMP("YTXCHG",$JOB,"WP",4))
+8 DO TR2WP^YTXCHGT($NAME(@TREE@("xchg","addendum")),INFO(4))
+9 ; remove so not included in spec
KILL @TREE@("xchg","addendum")
+10 QUIT
SENDMAIL ; interactive -- send instrument exchange entry in mail message
+1 QUIT
LOADMAIL ; interactive -- load instrument exchange entry from mail message
+1 QUIT
