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

YTXCHG.m

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