YTXCHGP ;SLC/KCM - MH Exchange Prompting ; 9/15/2015
;;5.01;MENTAL HEALTH;**121**;Dec 30, 1994;Build 61
;
LKUP(FILE) ; Lookup Mental Health Instrument & return IEN
; returns IEN, 0 for no selection, -1 for up-arrow or timeout
N DIC,X,Y,DTOUT,DUOUT
S DIC=FILE,DIC(0)="AEMQ" D ^DIC
S:Y<1 Y=0 S:$G(DUOUT)!$G(DTOUT) Y=-1
Q +Y
;
LIST(FILE,ENTRIES) ; Lookup in File to make list of ENTRIES
;.ENTRIES=total
;.ENTRIES(n)=ien
N I,IEN
S ENTRIES=0
F I=1:1 S IEN=$$LKUP(FILE) Q:IEN<1 S ENTRIES=I,ENTRIES(I)=IEN
I IEN<0 K ENTRIES S ENTRIES=0 ; ^out or timeout
Q
PRMTNAME(ASK,HELP,MAX) ; Prompt using ASK and return text or ""
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S MAX=$G(MAX,64)
S DIR(0)="FO^3:"_MAX,DIR("A")=ASK S:$L($G(HELP)) DIR("?")=HELP
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S Y=""
S Y=$$TRIM^XLFSTR(Y)
Q Y
;
CONFIRM(ASK,DFLT) ; return true if user confirms
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="YA",DIR("A")=ASK,DIR("B")=$G(DFLT,"YES")
D ^DIR
I $G(DUOUT)!$G(DTOUT) S Y=-1
Q +Y
;
PAUSE() ; prompt user for return to continue
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="EA",DIR("A")="Press return to continue..."
D ^DIR
Q
EDITWP(INSTRUCT,DEST) ; Edit word processing text in DEST
; INSTRUCT: instructions to user
; DEST: global reference for WP text
I $E($RE(DEST))=")" S $E(DEST,$L(DEST))=","
W !,INSTRUCT," --"
N DIC,DDWFLAGS,DWLW,DWPK
N I,J,X,X1 ; variables that DIWE seems to leave around
S DIC=DEST,DDWFLAGS="Q",DWLW=72,DWPK=1
D EN^DIWE
I '$D(@(DEST_"1,0)")) D
. S @(DEST_"0)")="^^1^1^"_DT_"^"
. S @(DEST_"1,0)")="(no description)"
Q
PICKTEST(TREE) ; Return a string of instruments selected]
N I,X,T,TESTS
S I=0 F S I=$O(@TREE@("test",I)) Q:'I D
. S TESTS=I
. S TESTS(I)=@TREE@("test",I,"info","name")
. S TESTS("B",$$LOW^XLFSTR(TESTS(I)))=I
I TESTS=1 Q 1 ; no prompting if only 1 tests
;
F D Q:X'["?"
. D TESTLIST
. W !!,"Choose instrument to browse: "
. R X:DTIME S:$E(X)="^" X="" Q:X=""
. S X=$$LOW^XLFSTR(X)
. I +X,$D(TESTS(X)) Q ; number entered
. I $D(TESTS("B",X)) S X=TESTS("B",X) Q ; full name entered
. S T=$O(TESTS("B",X)) ; partial name entered
. I X=$E(T,1,$L(X)) W " ",T S X=TESTS("B",T) Q
. W " ??",! S X="?" ; no match
Q X
;
TESTLIST ; Show a list of tests
; expects TESTS,TREE from PICKTEST
W !,"Instruments contained in ",@TREE@("xchg","name")," are:"
S I=0 F S I=$O(TESTS(I)) Q:'I W !,$J(I,4),?7,TESTS(I)
Q
SHOSUMM(YTXLOG,YTXDRY) ; Display summary log information
; may be called during KIDS build, so uses MES^XPDUTL
N MSG
I $G(YTXLOG("conflict")) D
. N I S I=0 F S I=$O(YTXLOG("conflict",I)) Q:'I D
. . S MSG="Conflict -- "_YTXLOG("conflict",I)
. . D MES^XPDUTL(MSG)
. S MSG="Conflicts with existing instruments prevent installation."
. D LOG^YTXCHGU("error",MSG)
. S MSG="Contact national support to resolve the conflicts."
. D MES^XPDUTL(MSG)
S MSG=" "_$G(YTXLOG("added"),0)_" records "_$S(YTXDRY:"would be ",1:"")_"added."
D MES^XPDUTL(MSG)
S MSG=" "_$G(YTXLOG("updated"),0)_" records "_$S(YTXDRY:"would be ",1:"")_"updated."
D MES^XPDUTL(MSG)
S MSG=" "_$G(YTXLOG("deleted"),0)_" records "_$S(YTXDRY:"would be ",1:"")_"deleted."
D MES^XPDUTL(MSG)
S MSG=" "_$G(YTXLOG("error"),0)_" errors."
D MES^XPDUTL(MSG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGP 3413 printed Sep 23, 2025@19:58:16 Page 2
YTXCHGP ;SLC/KCM - MH Exchange Prompting ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121**;Dec 30, 1994;Build 61
+2 ;
LKUP(FILE) ; Lookup Mental Health Instrument & return IEN
+1 ; returns IEN, 0 for no selection, -1 for up-arrow or timeout
+2 NEW DIC,X,Y,DTOUT,DUOUT
+3 SET DIC=FILE
SET DIC(0)="AEMQ"
DO ^DIC
+4 if Y<1
SET Y=0
if $GET(DUOUT)!$GET(DTOUT)
SET Y=-1
+5 QUIT +Y
+6 ;
LIST(FILE,ENTRIES) ; Lookup in File to make list of ENTRIES
+1 ;.ENTRIES=total
+2 ;.ENTRIES(n)=ien
+3 NEW I,IEN
+4 SET ENTRIES=0
+5 FOR I=1:1
SET IEN=$$LKUP(FILE)
if IEN<1
QUIT
SET ENTRIES=I
SET ENTRIES(I)=IEN
+6 ; ^out or timeout
IF IEN<0
KILL ENTRIES
SET ENTRIES=0
+7 QUIT
PRMTNAME(ASK,HELP,MAX) ; Prompt using ASK and return text or ""
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET MAX=$GET(MAX,64)
+3 SET DIR(0)="FO^3:"_MAX
SET DIR("A")=ASK
if $LENGTH($GET(HELP))
SET DIR("?")=HELP
+4 DO ^DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
SET Y=""
+6 SET Y=$$TRIM^XLFSTR(Y)
+7 QUIT Y
+8 ;
CONFIRM(ASK,DFLT) ; return true if user confirms
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="YA"
SET DIR("A")=ASK
SET DIR("B")=$GET(DFLT,"YES")
+3 DO ^DIR
+4 IF $GET(DUOUT)!$GET(DTOUT)
SET Y=-1
+5 QUIT +Y
+6 ;
PAUSE() ; prompt user for return to continue
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="EA"
SET DIR("A")="Press return to continue..."
+3 DO ^DIR
+4 QUIT
EDITWP(INSTRUCT,DEST) ; Edit word processing text in DEST
+1 ; INSTRUCT: instructions to user
+2 ; DEST: global reference for WP text
+3 IF $EXTRACT($REVERSE(DEST))=")"
SET $EXTRACT(DEST,$LENGTH(DEST))=","
+4 WRITE !,INSTRUCT," --"
+5 NEW DIC,DDWFLAGS,DWLW,DWPK
+6 ; variables that DIWE seems to leave around
NEW I,J,X,X1
+7 SET DIC=DEST
SET DDWFLAGS="Q"
SET DWLW=72
SET DWPK=1
+8 DO EN^DIWE
+9 IF '$DATA(@(DEST_"1,0)"))
Begin DoDot:1
+10 SET @(DEST_"0)")="^^1^1^"_DT_"^"
+11 SET @(DEST_"1,0)")="(no description)"
End DoDot:1
+12 QUIT
PICKTEST(TREE) ; Return a string of instruments selected]
+1 NEW I,X,T,TESTS
+2 SET I=0
FOR
SET I=$ORDER(@TREE@("test",I))
if 'I
QUIT
Begin DoDot:1
+3 SET TESTS=I
+4 SET TESTS(I)=@TREE@("test",I,"info","name")
+5 SET TESTS("B",$$LOW^XLFSTR(TESTS(I)))=I
End DoDot:1
+6 ; no prompting if only 1 tests
IF TESTS=1
QUIT 1
+7 ;
+8 FOR
Begin DoDot:1
+9 DO TESTLIST
+10 WRITE !!,"Choose instrument to browse: "
+11 READ X:DTIME
if $EXTRACT(X)="^"
SET X=""
if X=""
QUIT
+12 SET X=$$LOW^XLFSTR(X)
+13 ; number entered
IF +X
IF $DATA(TESTS(X))
QUIT
+14 ; full name entered
IF $DATA(TESTS("B",X))
SET X=TESTS("B",X)
QUIT
+15 ; partial name entered
SET T=$ORDER(TESTS("B",X))
+16 IF X=$EXTRACT(T,1,$LENGTH(X))
WRITE " ",T
SET X=TESTS("B",T)
QUIT
+17 ; no match
WRITE " ??",!
SET X="?"
End DoDot:1
if X'["?"
QUIT
+18 QUIT X
+19 ;
TESTLIST ; Show a list of tests
+1 ; expects TESTS,TREE from PICKTEST
+2 WRITE !,"Instruments contained in ",@TREE@("xchg","name")," are:"
+3 SET I=0
FOR
SET I=$ORDER(TESTS(I))
if 'I
QUIT
WRITE !,$JUSTIFY(I,4),?7,TESTS(I)
+4 QUIT
SHOSUMM(YTXLOG,YTXDRY) ; Display summary log information
+1 ; may be called during KIDS build, so uses MES^XPDUTL
+2 NEW MSG
+3 IF $GET(YTXLOG("conflict"))
Begin DoDot:1
+4 NEW I
SET I=0
FOR
SET I=$ORDER(YTXLOG("conflict",I))
if 'I
QUIT
Begin DoDot:2
+5 SET MSG="Conflict -- "_YTXLOG("conflict",I)
+6 DO MES^XPDUTL(MSG)
End DoDot:2
+7 SET MSG="Conflicts with existing instruments prevent installation."
+8 DO LOG^YTXCHGU("error",MSG)
+9 SET MSG="Contact national support to resolve the conflicts."
+10 DO MES^XPDUTL(MSG)
End DoDot:1
+11 SET MSG=" "_$GET(YTXLOG("added"),0)_" records "_$SELECT(YTXDRY:"would be ",1:"")_"added."
+12 DO MES^XPDUTL(MSG)
+13 SET MSG=" "_$GET(YTXLOG("updated"),0)_" records "_$SELECT(YTXDRY:"would be ",1:"")_"updated."
+14 DO MES^XPDUTL(MSG)
+15 SET MSG=" "_$GET(YTXLOG("deleted"),0)_" records "_$SELECT(YTXDRY:"would be ",1:"")_"deleted."
+16 DO MES^XPDUTL(MSG)
+17 SET MSG=" "_$GET(YTXLOG("error"),0)_" errors."
+18 DO MES^XPDUTL(MSG)
+19 QUIT
