YTXCHGL ;SLC/KCM - MH Exchange List Manager Calls ; 08-AUG-2016
;;5.01;MENTAL HEALTH;**121,218**;Dec 30, 1994;Build 9
;
EN ; -- main entry point for YTXCHG MAIN
D EN^VALM("YTXCHG MAIN")
D FULL^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)="Instrument Exchange File Entries"
Q
;
INIT ; -- init variables and list array
K ^TMP("YTXLST",$J)
N CNT,NM,DT,IEN,ROW,X0,PKEY
D OWNSKEY^XUSRB(.PKEY,"XUPROG")
S CNT=0
S NM="" F S NM=$O(^YTT(601.95,"C",NM)) Q:NM="" D
. S DT=0 F S DT=$O(^YTT(601.95,"C",NM,DT)) Q:'DT D
. . S IEN=0 F S IEN=$O(^YTT(601.95,"C",NM,DT,IEN)) Q:'IEN D
. . . S X0=^YTT(601.95,IEN,0)
. . . I 'PKEY(0),$P(X0,U,3)="backup copy" Q ; screen out backup copies
. . . S CNT=CNT+1,ROW=""
. . . S ROW=$$SETFLD^VALM1(CNT,ROW,"ITEM")
. . . S ROW=$$SETFLD^VALM1($P(X0,U),ROW,"ENTRY")
. . . S ROW=$$SETFLD^VALM1($P(X0,U,3),ROW,"SOURCE")
. . . S ROW=$$SETFLD^VALM1($$FMTE^XLFDT($P(X0,U,2),"5Z"),ROW,"CREATED")
. . . S ^TMP("YTXLST",$J,CNT,0)=ROW
. . . S ^TMP("YTXLST",$J,"IDX",CNT,IEN)=""
S VALMCNT=CNT
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
EXIT ; -- exit code
Q
EXPND ; -- expand code
Q
;
CREATE ; create new instrument exchange entry
D FULL^VALM1
K ^TMP("YTXCHG",$J,"WP",2)
N TESTS,REC
D LIST^YTXCHGP(601.71,.TESTS) I TESTS=0 G XREFR
S REC(.01)=$$PRMTNAME^YTXCHGP("Exchange Name") I '$L(REC(.01)) G XREFR ; name
S REC(.02)=$$NOW^XLFDT ; date/time
S REC(.03)=$P($$GET1^DIQ(200,DUZ,.01),",")_"@"_$P($$SITE^VASITE,U,2) ; source
S REC(2)=$NA(^TMP("YTXCHG",$J,"WP",2)) ; description
D EDITWP^YTXCHGP("Enter a description for "_REC(.01),REC(2))
W !!,"Creating:",?11,REC(.01)
W !,?11,$$FMTE^XLFDT(REC(.02),"5Z")
D CREATE^YTXCHG(.TESTS,.REC)
K ^TMP("YTXCHG",$J,"WP",2)
D XPAUSE
Q
REBUILD ; rebuild spec for existing exchange entry (with new date)
D FULL^VALM1
N XCHGIEN,INFO,TESTS,I
S XCHGIEN=$$SELECT() I 'XCHGIEN G XREFR
K ^TMP("YTXCHG",$J,"WP")
D INFO^YTXCHG(XCHGIEN,.INFO)
W !!," Rebuilding:",?14,INFO(.01)
W !,?14,$$FMTE^XLFDT(INFO(.02),"5Z")
W !,"Instruments:"
S I=0 F S I=$O(INFO("tests",I)) Q:'I D
. W ?14,INFO("tests",I),!
. S TESTS(I)=$O(^YTT(601.71,"B",INFO("tests",I),0))
K INFO("tests")
I $$CONFIRM^YTXCHGP("Do you want to continue? ")<1 G XREBUILD
D DELETE^YTXCHG(XCHGIEN)
D CREATE^YTXCHG(.TESTS,.INFO)
D XPAUSE
XREBUILD ; exit REBUILD here
K ^TMP("YTXCHG",$J,"WP")
Q
DELETE ; delete instrument exchange entry
N XCHGIEN,XCHGNM
S XCHGIEN=$$SELECT() I 'XCHGIEN G XREFR
S XCHGNM=$P(^YTT(601.95,XCHGIEN,0),U)
I $$CONFIRM^YTXCHGP("Are you sure you want to delete "_XCHGNM_"? ")<1 G XREFR
D DELETE^YTXCHG(XCHGIEN)
D XINIT
Q
DRYRUN ; Trial install without database changes
N DRYRUN S DRYRUN=1
; drop through to install with DRYRUN set
INSTALL ; Install instrument exchange entry locally
D FULL^VALM1
N XCHGIEN,STATS,YTXVRB
S XCHGIEN=$$SELECT() I 'XCHGIEN G XREFR
S YTXVRB=$$CONFIRM^YTXCHGP("Use verbose mode? ","No") G:YTXVRB<0 XREFR
W !!,$S($G(DRYRUN):"Trial ",1:"")_"Installing "_$P(^YTT(601.95,XCHGIEN,0),U)
I $G(DRYRUN) W !,"*** No database changes will be made. ***",!
D INSTALL^YTXCHG(XCHGIEN,$G(DRYRUN))
D XPAUSE
Q
BROWSE ; Browse instrument specification
D FULL^VALM1
N XCHGIEN,NUM,NAME
S XCHGIEN=$$SELECT() I 'XCHGIEN G XREFR
K ^TMP("YTXCHG",$J,"TREE")
K ^TMP("YTXCHG",$J,"BROWSE")
D SPEC2TR^YTXCHGT(XCHGIEN,$NA(^TMP("YTXCHG",$J,"TREE")))
S NUM=$$PICKTEST^YTXCHGP($NA(^TMP("YTXCHG",$J,"TREE"))) I 'NUM G XREFR
S NAME=^TMP("YTXCHG",$J,"TREE","test",NUM,"info","name")_" Specification"
D BLDVIEW^YTXCHG($NA(^TMP("YTXCHG",$J,"TREE","test",NUM)),$NA(^TMP("YTXCHG",$J,"BROWSE")))
D BROWSE^DDBR($NA(^TMP("YTXCHG",$J,"BROWSE")),"NR",NAME)
K ^TMP("YTXCHG",$J,"TREE")
K ^TMP("YTXCHG",$J,"BROWSE")
D XREFR
Q
SAVEHOST ; Save exchange entry to host file
N XCHGIEN,FULLNM,OK
S XCHGIEN=$$SELECT() I 'XCHGIEN G XREFR
I $D(^YTT(601.95,XCHGIEN,1))'>1 W !,"No data to save." G XREFR
S FULLNM=$$PRMTNAME^YTXCHGP("Enter file name","Enter full path and filename.",245)
I '$L(FULLNM) G XREFR
S OK=$$SAVEHFS^YTXCHG(XCHGIEN,FULLNM)
W !,$S(OK:"File saved.",1:"Save failed.")
D XPAUSE
Q
LOADHOST ; Load exchange entry from host file
D FULL^VALM1
K ^TMP("YTXCHG",$J,"WP")
N FULLNM,XCHGREC
S FULLNM=$$PRMTNAME^YTXCHGP("Enter file name","Enter full path and filename.",245)
I '$L(FULLNM) G XREFR
D LOADFILE^YTXCHG(FULLNM,.XCHGREC) I $G(XCHGREC)=-1 G XLOADHST
D LOAD2FM(.XCHGREC)
XLOADHST ; exit LOADHOST here
D XPAUSE
K ^TMP("YTXCHG",$J,"WP")
Q
LOADURL ; Load exchange entry from URL
D FULL^VALM1
K ^TMP("YTXCHG",$J,"WP")
N URL,XCHGREC
S URL=$$PRMTNAME^YTXCHGP("Enter the URL","Enter the full URL of the desired file.",245)
S URL=$$LOW^XLFSTR(URL)
I '$L(URL) G XREFR
D LOADFILE^YTXCHG(URL,.XCHGREC) I $G(XCHGREC)=-1 G XLOADURL
D LOAD2FM(.XCHGREC)
XLOADURL ; exit LOADURL here
D XPAUSE
K ^TMP("YTXCHG",$J,"WP")
Q
LOAD2FM(XCHGREC) ; confirm and load into Fileman entry (file 601.95)
N I,REPLACE,XCHGIEN
I '$L($G(XCHGREC(.01)))!'$L($G(XCHGREC(.02))) W !,"File is wrong format." QUIT
W !
W !,"This will load: "_XCHGREC(.01)
W !," created on: "_$$FMTE^XLFDT(XCHGREC(.02),"5Z")
W !," source: "_XCHGREC(.03)
W !,"Description ---"
S I=0 F S I=$O(^TMP("YTXCHG",$J,"WP",2,I)) Q:'I W !,?3,^TMP("YTXCHG",$J,"WP",2,I,0)
S REPLACE=$D(^YTT(601.95,"C",XCHGREC(.01),XCHGREC(.02)))
I REPLACE W !!,">>> This will OVERWRITE the current entry!"
I '$$CONFIRM^YTXCHGP("Do you want to continue? ",$S(REPLACE:"No",1:"Yes")) QUIT
I REPLACE D
. S XCHGIEN=$O(^YTT(601.95,"C",XCHGREC(.01),XCHGREC(.02),0))
. D FMUPD^YTXCHGU(601.95,.XCHGREC,.XCHGIEN)
E D FMADD^YTXCHGU(601.95,.XCHGREC,.XCHGIEN)
W !,$P(^YTT(601.95,XCHGIEN,0),U)_" loaded."
Q
;
XINIT ; exit back to LM, update listing
D INIT S VALMBCK="R"
Q
XPAUSE ; exit back to LM, pause first
D PAUSE^YTXCHGP
D INIT S VALMBCK="R"
Q
XREFR ; exit back to LM, refresh screen only
S VALMBCK="R"
Q
;
SELECT() ; return IEN for selection from list
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IEN
S DIR(0)="N^1:"_VALMCNT_":0"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q 0
I 'Y Q 0
S IEN=$O(@VALMAR@("IDX",+Y,""))
Q IEN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGL 6377 printed Dec 13, 2024@02:22:05 Page 2
YTXCHGL ;SLC/KCM - MH Exchange List Manager Calls ; 08-AUG-2016
+1 ;;5.01;MENTAL HEALTH;**121,218**;Dec 30, 1994;Build 9
+2 ;
EN ; -- main entry point for YTXCHG MAIN
+1 DO EN^VALM("YTXCHG MAIN")
+2 DO FULL^VALM1
+3 QUIT
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Instrument Exchange File Entries"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("YTXLST",$JOB)
+2 NEW CNT,NM,DT,IEN,ROW,X0,PKEY
+3 DO OWNSKEY^XUSRB(.PKEY,"XUPROG")
+4 SET CNT=0
+5 SET NM=""
FOR
SET NM=$ORDER(^YTT(601.95,"C",NM))
if NM=""
QUIT
Begin DoDot:1
+6 SET DT=0
FOR
SET DT=$ORDER(^YTT(601.95,"C",NM,DT))
if 'DT
QUIT
Begin DoDot:2
+7 SET IEN=0
FOR
SET IEN=$ORDER(^YTT(601.95,"C",NM,DT,IEN))
if 'IEN
QUIT
Begin DoDot:3
+8 SET X0=^YTT(601.95,IEN,0)
+9 ; screen out backup copies
IF 'PKEY(0)
IF $PIECE(X0,U,3)="backup copy"
QUIT
+10 SET CNT=CNT+1
SET ROW=""
+11 SET ROW=$$SETFLD^VALM1(CNT,ROW,"ITEM")
+12 SET ROW=$$SETFLD^VALM1($PIECE(X0,U),ROW,"ENTRY")
+13 SET ROW=$$SETFLD^VALM1($PIECE(X0,U,3),ROW,"SOURCE")
+14 SET ROW=$$SETFLD^VALM1($$FMTE^XLFDT($PIECE(X0,U,2),"5Z"),ROW,"CREATED")
+15 SET ^TMP("YTXLST",$JOB,CNT,0)=ROW
+16 SET ^TMP("YTXLST",$JOB,"IDX",CNT,IEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+17 SET VALMCNT=CNT
+18 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
EXIT ; -- exit code
+1 QUIT
EXPND ; -- expand code
+1 QUIT
+2 ;
CREATE ; create new instrument exchange entry
+1 DO FULL^VALM1
+2 KILL ^TMP("YTXCHG",$JOB,"WP",2)
+3 NEW TESTS,REC
+4 DO LIST^YTXCHGP(601.71,.TESTS)
IF TESTS=0
GOTO XREFR
+5 ; name
SET REC(.01)=$$PRMTNAME^YTXCHGP("Exchange Name")
IF '$LENGTH(REC(.01))
GOTO XREFR
+6 ; date/time
SET REC(.02)=$$NOW^XLFDT
+7 ; source
SET REC(.03)=$PIECE($$GET1^DIQ(200,DUZ,.01),",")_"@"_$PIECE($$SITE^VASITE,U,2)
+8 ; description
SET REC(2)=$NAME(^TMP("YTXCHG",$JOB,"WP",2))
+9 DO EDITWP^YTXCHGP("Enter a description for "_REC(.01),REC(2))
+10 WRITE !!,"Creating:",?11,REC(.01)
+11 WRITE !,?11,$$FMTE^XLFDT(REC(.02),"5Z")
+12 DO CREATE^YTXCHG(.TESTS,.REC)
+13 KILL ^TMP("YTXCHG",$JOB,"WP",2)
+14 DO XPAUSE
+15 QUIT
REBUILD ; rebuild spec for existing exchange entry (with new date)
+1 DO FULL^VALM1
+2 NEW XCHGIEN,INFO,TESTS,I
+3 SET XCHGIEN=$$SELECT()
IF 'XCHGIEN
GOTO XREFR
+4 KILL ^TMP("YTXCHG",$JOB,"WP")
+5 DO INFO^YTXCHG(XCHGIEN,.INFO)
+6 WRITE !!," Rebuilding:",?14,INFO(.01)
+7 WRITE !,?14,$$FMTE^XLFDT(INFO(.02),"5Z")
+8 WRITE !,"Instruments:"
+9 SET I=0
FOR
SET I=$ORDER(INFO("tests",I))
if 'I
QUIT
Begin DoDot:1
+10 WRITE ?14,INFO("tests",I),!
+11 SET TESTS(I)=$ORDER(^YTT(601.71,"B",INFO("tests",I),0))
End DoDot:1
+12 KILL INFO("tests")
+13 IF $$CONFIRM^YTXCHGP("Do you want to continue? ")<1
GOTO XREBUILD
+14 DO DELETE^YTXCHG(XCHGIEN)
+15 DO CREATE^YTXCHG(.TESTS,.INFO)
+16 DO XPAUSE
XREBUILD ; exit REBUILD here
+1 KILL ^TMP("YTXCHG",$JOB,"WP")
+2 QUIT
DELETE ; delete instrument exchange entry
+1 NEW XCHGIEN,XCHGNM
+2 SET XCHGIEN=$$SELECT()
IF 'XCHGIEN
GOTO XREFR
+3 SET XCHGNM=$PIECE(^YTT(601.95,XCHGIEN,0),U)
+4 IF $$CONFIRM^YTXCHGP("Are you sure you want to delete "_XCHGNM_"? ")<1
GOTO XREFR
+5 DO DELETE^YTXCHG(XCHGIEN)
+6 DO XINIT
+7 QUIT
DRYRUN ; Trial install without database changes
+1 NEW DRYRUN
SET DRYRUN=1
+2 ; drop through to install with DRYRUN set
INSTALL ; Install instrument exchange entry locally
+1 DO FULL^VALM1
+2 NEW XCHGIEN,STATS,YTXVRB
+3 SET XCHGIEN=$$SELECT()
IF 'XCHGIEN
GOTO XREFR
+4 SET YTXVRB=$$CONFIRM^YTXCHGP("Use verbose mode? ","No")
if YTXVRB<0
GOTO XREFR
+5 WRITE !!,$SELECT($GET(DRYRUN):"Trial ",1:"")_"Installing "_$PIECE(^YTT(601.95,XCHGIEN,0),U)
+6 IF $GET(DRYRUN)
WRITE !,"*** No database changes will be made. ***",!
+7 DO INSTALL^YTXCHG(XCHGIEN,$GET(DRYRUN))
+8 DO XPAUSE
+9 QUIT
BROWSE ; Browse instrument specification
+1 DO FULL^VALM1
+2 NEW XCHGIEN,NUM,NAME
+3 SET XCHGIEN=$$SELECT()
IF 'XCHGIEN
GOTO XREFR
+4 KILL ^TMP("YTXCHG",$JOB,"TREE")
+5 KILL ^TMP("YTXCHG",$JOB,"BROWSE")
+6 DO SPEC2TR^YTXCHGT(XCHGIEN,$NAME(^TMP("YTXCHG",$JOB,"TREE")))
+7 SET NUM=$$PICKTEST^YTXCHGP($NAME(^TMP("YTXCHG",$JOB,"TREE")))
IF 'NUM
GOTO XREFR
+8 SET NAME=^TMP("YTXCHG",$JOB,"TREE","test",NUM,"info","name")_" Specification"
+9 DO BLDVIEW^YTXCHG($NAME(^TMP("YTXCHG",$JOB,"TREE","test",NUM)),$NAME(^TMP("YTXCHG",$JOB,"BROWSE")))
+10 DO BROWSE^DDBR($NAME(^TMP("YTXCHG",$JOB,"BROWSE")),"NR",NAME)
+11 KILL ^TMP("YTXCHG",$JOB,"TREE")
+12 KILL ^TMP("YTXCHG",$JOB,"BROWSE")
+13 DO XREFR
+14 QUIT
SAVEHOST ; Save exchange entry to host file
+1 NEW XCHGIEN,FULLNM,OK
+2 SET XCHGIEN=$$SELECT()
IF 'XCHGIEN
GOTO XREFR
+3 IF $DATA(^YTT(601.95,XCHGIEN,1))'>1
WRITE !,"No data to save."
GOTO XREFR
+4 SET FULLNM=$$PRMTNAME^YTXCHGP("Enter file name","Enter full path and filename.",245)
+5 IF '$LENGTH(FULLNM)
GOTO XREFR
+6 SET OK=$$SAVEHFS^YTXCHG(XCHGIEN,FULLNM)
+7 WRITE !,$SELECT(OK:"File saved.",1:"Save failed.")
+8 DO XPAUSE
+9 QUIT
LOADHOST ; Load exchange entry from host file
+1 DO FULL^VALM1
+2 KILL ^TMP("YTXCHG",$JOB,"WP")
+3 NEW FULLNM,XCHGREC
+4 SET FULLNM=$$PRMTNAME^YTXCHGP("Enter file name","Enter full path and filename.",245)
+5 IF '$LENGTH(FULLNM)
GOTO XREFR
+6 DO LOADFILE^YTXCHG(FULLNM,.XCHGREC)
IF $GET(XCHGREC)=-1
GOTO XLOADHST
+7 DO LOAD2FM(.XCHGREC)
XLOADHST ; exit LOADHOST here
+1 DO XPAUSE
+2 KILL ^TMP("YTXCHG",$JOB,"WP")
+3 QUIT
LOADURL ; Load exchange entry from URL
+1 DO FULL^VALM1
+2 KILL ^TMP("YTXCHG",$JOB,"WP")
+3 NEW URL,XCHGREC
+4 SET URL=$$PRMTNAME^YTXCHGP("Enter the URL","Enter the full URL of the desired file.",245)
+5 SET URL=$$LOW^XLFSTR(URL)
+6 IF '$LENGTH(URL)
GOTO XREFR
+7 DO LOADFILE^YTXCHG(URL,.XCHGREC)
IF $GET(XCHGREC)=-1
GOTO XLOADURL
+8 DO LOAD2FM(.XCHGREC)
XLOADURL ; exit LOADURL here
+1 DO XPAUSE
+2 KILL ^TMP("YTXCHG",$JOB,"WP")
+3 QUIT
LOAD2FM(XCHGREC) ; confirm and load into Fileman entry (file 601.95)
+1 NEW I,REPLACE,XCHGIEN
+2 IF '$LENGTH($GET(XCHGREC(.01)))!'$LENGTH($GET(XCHGREC(.02)))
WRITE !,"File is wrong format."
QUIT
+3 WRITE !
+4 WRITE !,"This will load: "_XCHGREC(.01)
+5 WRITE !," created on: "_$$FMTE^XLFDT(XCHGREC(.02),"5Z")
+6 WRITE !," source: "_XCHGREC(.03)
+7 WRITE !,"Description ---"
+8 SET I=0
FOR
SET I=$ORDER(^TMP("YTXCHG",$JOB,"WP",2,I))
if 'I
QUIT
WRITE !,?3,^TMP("YTXCHG",$JOB,"WP",2,I,0)
+9 SET REPLACE=$DATA(^YTT(601.95,"C",XCHGREC(.01),XCHGREC(.02)))
+10 IF REPLACE
WRITE !!,">>> This will OVERWRITE the current entry!"
+11 IF '$$CONFIRM^YTXCHGP("Do you want to continue? ",$SELECT(REPLACE:"No",1:"Yes"))
QUIT
+12 IF REPLACE
Begin DoDot:1
+13 SET XCHGIEN=$ORDER(^YTT(601.95,"C",XCHGREC(.01),XCHGREC(.02),0))
+14 DO FMUPD^YTXCHGU(601.95,.XCHGREC,.XCHGIEN)
End DoDot:1
+15 IF '$TEST
DO FMADD^YTXCHGU(601.95,.XCHGREC,.XCHGIEN)
+16 WRITE !,$PIECE(^YTT(601.95,XCHGIEN,0),U)_" loaded."
+17 QUIT
+18 ;
XINIT ; exit back to LM, update listing
+1 DO INIT
SET VALMBCK="R"
+2 QUIT
XPAUSE ; exit back to LM, pause first
+1 DO PAUSE^YTXCHGP
+2 DO INIT
SET VALMBCK="R"
+3 QUIT
XREFR ; exit back to LM, refresh screen only
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
SELECT() ; return IEN for selection from list
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IEN
+2 SET DIR(0)="N^1:"_VALMCNT_":0"
+3 DO ^DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT 0
+5 IF 'Y
QUIT 0
+6 SET IEN=$ORDER(@VALMAR@("IDX",+Y,""))
+7 QUIT IEN
+8 ;
