- 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 Jan 18, 2025@03:23:11 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