DIEH ;SFISC/STAFF-HELP ;13APR2004
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
GET(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
GETX ;
N DIEHZ,DIEHD,DIEHEXIT,DIEHPF,DIEHUFLG
S DIEHUFLG=$G(DIEHFLG)
I '$G(DIQUIET) N DIQUIET S DIQUIET=1
I '$G(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
I $G(DIEHIEN)]"" N DA,C,D,I D DA^DIEFU(DIEHIEN,.DA) S C=$L(DIEHIEN,",")-1 F I=1:1:C S D="D"_(C-I) N @D S @D=$P(DIEHIEN,",",I)
S DIEHZ=$$ZERO(DIEHF,DIEHFLD) I DIEHZ=0 G GETOUT
S DIEHD=$P(DIEHZ,U,2)
D BLDFLGS G:$G(DIEHEXIT) GETOUT
I DIEHD["P" S DIEHPF=+$P(DIEHD,"P",2)
S DIHELP=+$O(^TMP("DIHELP",$J,""),-1)
I DIEHUFLG["F",DIEHFLD=.01 D PXREFS(DIEHF,DIEHFLD)
I DIEHUFLG["H" D HPROMPT(DIEHF,DIEHFLD)
I DIEHUFLG["X" D XHLP(DIEHF,DIEHFLD)
I DIEHUFLG["D" D DESCR(DIEHF,DIEHFLD)
I DIEHUFLG["P" D SCRNDES(DIEHF,DIEHFLD)
I DIEHUFLG["C" D SCRNDES(DIEHF,DIEHFLD)
I DIEHUFLG["T" N DIEHDT S DIEHDT=$P($P($P(DIEHZ,U,5,99),"%DT=""",2),"""",1) D DT^DIEH1(DIEHDT)
I DIEHUFLG["S" D SCRNCD(DIEHF,DIEHFLD,DIEHZ)
I DIEHUFLG["U" D UNSCRNCD(DIEHZ)
I DIEHUFLG["V" D VPMSG(DIEHF,DIEHFLD)
I DIEHUFLG["B",DIEHUFLG'["b" D BLD^DIALOG(9115)
I DIEHUFLG["M" D BLD^DIALOG(9116)
I DIEHUFLG["G",DIEHFLG'["g",$G(DIEHPF) D FOLLOW(DIEHPF,DIEHFLG)
I '$G(DIHELP) K DIHELP
GETOUT I $D(DIEHOUT) D CALLOUT^DIEFU(DIEHOUT)
Q
;
BLDFLGS ;
N A1,A2,C1,C2,DIEHGFLG
S C1="HX",C2="XD",(A1,A2)=""
I DIEHD S DIEHF=+DIEHD,DIEHFLD=.01,DIEHD=$P(^DD(DIEHF,.01,0),U,2)
I DIEHD["W" S (A1,A2)="HD"
E I DIEHD["D" S (A1,A2)="T"
E I DIEHD["S" S A1="CS",A2="S",DIEHGFLG="U"
E I DIEHD["P" S A1="PG",A2="G",DIEHGFLG="F"
E I DIEHD="V" S A1="VB",A2="VMB"
I DIEHFLD=.01,'$D(^DD(DIEHF,0,"UP")) S A1=A1_"F",A2=A2_"F"
I DIEHUFLG'["r",'$$VERFLG^DIEFU(DIEHUFLG,"bgA?"_C1_C2_A1_A2_$G(DIEHGFLG)) S DIEHEXIT=1
I DIEHUFLG["??" S DIEHUFLG=DIEHUFLG_C2_A2
E I DIEHUFLG["?" S DIEHUFLG=DIEHUFLG_C1_A1
E I DIEHUFLG["A" S DIEHUFLG=$TR(C1_C2_A1_A2,"S","U")
Q
;
ZERO(F,D) ;
I '$$VFILE^DIEFU(F,"D") Q 0
I '$$VFIELD^DIEFU(F,D,"D") Q 0
Q ^DD(F,D,0)
;
BN ;Insert blank node.
S:DIHELP DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=""
Q
;
HPROMPT(F,D) ;
N T
S T=$$HELP^DIALOGZ(F,D)
I $L(T) D
. D BN
. S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=T
Q
;
XHLP(DIEHF,DIEHFLD) ;
;DA() and D0,D1,etc. passed thru symbol table.
N DIEHXH S DIEHXH=$G(^DD(DIEHF,DIEHFLD,4))
I $L(DIEHXH) D
. D BN
. N DIEHECNT S DIEHECNT=$G(DIERR)
. N DDIOLFLG S DDIOLFLG="H" X DIEHXH
. I DIEHECNT'=$G(DIERR) D HKERR^DILIBF(DIEHF,"",DIEHFLD,"Xecutable Help")
Q
;
DESCR(F,D) ;
N L
S L=$P($G(^DD(F,D,21,0)),U,3)
I L D
. D BN
. N I F I=1:1:L S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=^DD(F,D,21,I,0)
. Q
Q
;
PXREFS(DIEHF,DIEHFLD) ;
N DIF,DIFD,DIEHROOT,DIEHIXID,DIEHIXP,DIEHIXNM,DIFULL
S DIEHIXP=$$FILENM^DIEFU(DIEHF)_" "
D GETIXNM(DIEHF,.DIEHIXNM)
S DIF=""
F S DIF=$O(DIEHIXNM(DIF)) Q:DIF="" D Q:$D(DIFULL)
. S DIFD=""
. F S DIFD=$O(DIEHIXNM(DIF,DIFD)) Q:DIFD="" D Q:$D(DIFULL)
. . I $L(DIEHIXP)+$L(DIEHIXNM(DIF,DIFD))>240 D Q
. . . S DIEHIXP=DIEHIXP_", etc "
. . . S DIFULL=1
. . S DIEHIXP=DIEHIXP_DIEHIXNM(DIF,DIFD)_", or "
S DIEHIXP=$E(DIEHIXP,1,$L(DIEHIXP)-5)
D BLD^DIALOG(9105,DIEHIXP)
Q
;
GETIXNM(DIEHF,DIEHIXNM) ;
S DIEHROOT=$$ROOT^DIQGU(DIEHF,"",1)
S DIEHIXID="Az"
F S DIEHIXID=$O(@DIEHROOT@(DIEHIXID)) Q:DIEHIXID="" D
. N DIEHIXF,DIEHIXFD
. S DIEHIXF=$O(^DD(DIEHF,0,"IX",DIEHIXID,"")) Q:DIEHIXF=""
. S DIEHIXFD=$O(^DD(DIEHF,0,"IX",DIEHIXID,DIEHIXF,"")) Q:DIEHIXFD=""
. S DIEHIXNM(DIEHIXF,DIEHIXFD)=$$FLDNM^DIEFU(DIEHIXF,DIEHIXFD)
Q
;
SCRNDES(F,D) ;
N T
S T=$G(^DD(F,D,12))
I $L(T) D
. D BN
. S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=T
. Q
Q
;
SCRNCD(F,D,DIEHZ) ;
N S,DIC,Y,A,T,I
I $P(DIEHZ,U,2)'["*" D UNSCRNCD(DIEHZ) Q
S S=$G(^DD(F,D,12.1))
I S="" D UNSCRNCD(DIEHZ) Q
D CODES
I $D(Y) D
. N DIEHECNT S DIEHECNT=$G(DIERR)
. D SETSCR^DIR(F,D)
. D BLD^DIALOG(9101)
. F I=1:1:T D
. . S Y=$P(Y(I),";",1)
. . X DIC("S") I D CODESOUT
. I DIEHECNT'=$G(DIERR) D HKERR^DILIBF(F,"",D,"set of codes screen")
Q
UNSCRNCD(DIEHZ) ;
N Y,A,T,I
D CODES
I $D(Y) D
. D BLD^DIALOG(9101)
. F I=1:1:T D CODESOUT
. Q
Q
;
CODES ;
S A=$P(DIEHZ,U,3) I $G(DUZ("LANG"))>1,A=$P(^DD(DIEHF,DIEHFLD,0),U,3) S A=$$SETIN^DIALOGZ_";" ;NAKED
I A]"" D
. S T=$L(A,";")-1
. F I=1:1:T S Y(I)=$P(A,";",I)
. Q
Q
;
CODESOUT ;
S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=$P(Y(I),":",1)_" "_$P(Y(I),":",2)
Q
;
VPMSG(F,D) ;
N I,N,P,L
D BLD^DIALOG(9103)
S I=0 F S I=$O(^DD(F,D,"V",I)) Q:I="B" S N=^(I,0) D
. S P(1)=$P(N,U,4),P(2)=$P(N,U,2),L=$S(I=1:"",1:"S")
. D BLD^DIALOG(9117,.P,.P,"",L)
. Q
Q
;
FOLLOW(DIEHPF,DIEHUFLG) ;
D GET(DIEHPF,"",.01,DIEHUFLG_"r")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIEH 5068 printed Dec 13, 2024@02:47:10 Page 2
DIEH ;SFISC/STAFF-HELP ;13APR2004
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
GET(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ;
GETX ;
+1 NEW DIEHZ,DIEHD,DIEHEXIT,DIEHPF,DIEHUFLG
+2 SET DIEHUFLG=$GET(DIEHFLG)
+3 IF '$GET(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+4 IF '$GET(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+5 IF $GET(DIEHIEN)]""
NEW DA,C,D,I
DO DA^DIEFU(DIEHIEN,.DA)
SET C=$LENGTH(DIEHIEN,",")-1
FOR I=1:1:C
SET D="D"_(C-I)
NEW @D
SET @D=$PIECE(DIEHIEN,",",I)
+6 SET DIEHZ=$$ZERO(DIEHF,DIEHFLD)
IF DIEHZ=0
GOTO GETOUT
+7 SET DIEHD=$PIECE(DIEHZ,U,2)
+8 DO BLDFLGS
if $GET(DIEHEXIT)
GOTO GETOUT
+9 IF DIEHD["P"
SET DIEHPF=+$PIECE(DIEHD,"P",2)
+10 SET DIHELP=+$ORDER(^TMP("DIHELP",$JOB,""),-1)
+11 IF DIEHUFLG["F"
IF DIEHFLD=.01
DO PXREFS(DIEHF,DIEHFLD)
+12 IF DIEHUFLG["H"
DO HPROMPT(DIEHF,DIEHFLD)
+13 IF DIEHUFLG["X"
DO XHLP(DIEHF,DIEHFLD)
+14 IF DIEHUFLG["D"
DO DESCR(DIEHF,DIEHFLD)
+15 IF DIEHUFLG["P"
DO SCRNDES(DIEHF,DIEHFLD)
+16 IF DIEHUFLG["C"
DO SCRNDES(DIEHF,DIEHFLD)
+17 IF DIEHUFLG["T"
NEW DIEHDT
SET DIEHDT=$PIECE($PIECE($PIECE(DIEHZ,U,5,99),"%DT=""",2),"""",1)
DO DT^DIEH1(DIEHDT)
+18 IF DIEHUFLG["S"
DO SCRNCD(DIEHF,DIEHFLD,DIEHZ)
+19 IF DIEHUFLG["U"
DO UNSCRNCD(DIEHZ)
+20 IF DIEHUFLG["V"
DO VPMSG(DIEHF,DIEHFLD)
+21 IF DIEHUFLG["B"
IF DIEHUFLG'["b"
DO BLD^DIALOG(9115)
+22 IF DIEHUFLG["M"
DO BLD^DIALOG(9116)
+23 IF DIEHUFLG["G"
IF DIEHFLG'["g"
IF $GET(DIEHPF)
DO FOLLOW(DIEHPF,DIEHFLG)
+24 IF '$GET(DIHELP)
KILL DIHELP
GETOUT IF $DATA(DIEHOUT)
DO CALLOUT^DIEFU(DIEHOUT)
+1 QUIT
+2 ;
BLDFLGS ;
+1 NEW A1,A2,C1,C2,DIEHGFLG
+2 SET C1="HX"
SET C2="XD"
SET (A1,A2)=""
+3 IF DIEHD
SET DIEHF=+DIEHD
SET DIEHFLD=.01
SET DIEHD=$PIECE(^DD(DIEHF,.01,0),U,2)
+4 IF DIEHD["W"
SET (A1,A2)="HD"
+5 IF '$TEST
IF DIEHD["D"
SET (A1,A2)="T"
+6 IF '$TEST
IF DIEHD["S"
SET A1="CS"
SET A2="S"
SET DIEHGFLG="U"
+7 IF '$TEST
IF DIEHD["P"
SET A1="PG"
SET A2="G"
SET DIEHGFLG="F"
+8 IF '$TEST
IF DIEHD="V"
SET A1="VB"
SET A2="VMB"
+9 IF DIEHFLD=.01
IF '$DATA(^DD(DIEHF,0,"UP"))
SET A1=A1_"F"
SET A2=A2_"F"
+10 IF DIEHUFLG'["r"
IF '$$VERFLG^DIEFU(DIEHUFLG,"bgA?"_C1_C2_A1_A2_$GET(DIEHGFLG))
SET DIEHEXIT=1
+11 IF DIEHUFLG["??"
SET DIEHUFLG=DIEHUFLG_C2_A2
+12 IF '$TEST
IF DIEHUFLG["?"
SET DIEHUFLG=DIEHUFLG_C1_A1
+13 IF '$TEST
IF DIEHUFLG["A"
SET DIEHUFLG=$TRANSLATE(C1_C2_A1_A2,"S","U")
+14 QUIT
+15 ;
ZERO(F,D) ;
+1 IF '$$VFILE^DIEFU(F,"D")
QUIT 0
+2 IF '$$VFIELD^DIEFU(F,D,"D")
QUIT 0
+3 QUIT ^DD(F,D,0)
+4 ;
BN ;Insert blank node.
+1 if DIHELP
SET DIHELP=DIHELP+1
SET ^TMP("DIHELP",$JOB,DIHELP)=""
+2 QUIT
+3 ;
HPROMPT(F,D) ;
+1 NEW T
+2 SET T=$$HELP^DIALOGZ(F,D)
+3 IF $LENGTH(T)
Begin DoDot:1
+4 DO BN
+5 SET DIHELP=DIHELP+1
SET ^TMP("DIHELP",$JOB,DIHELP)=T
End DoDot:1
+6 QUIT
+7 ;
XHLP(DIEHF,DIEHFLD) ;
+1 ;DA() and D0,D1,etc. passed thru symbol table.
+2 NEW DIEHXH
SET DIEHXH=$GET(^DD(DIEHF,DIEHFLD,4))
+3 IF $LENGTH(DIEHXH)
Begin DoDot:1
+4 DO BN
+5 NEW DIEHECNT
SET DIEHECNT=$GET(DIERR)
+6 NEW DDIOLFLG
SET DDIOLFLG="H"
XECUTE DIEHXH
+7 IF DIEHECNT'=$GET(DIERR)
DO HKERR^DILIBF(DIEHF,"",DIEHFLD,"Xecutable Help")
End DoDot:1
+8 QUIT
+9 ;
DESCR(F,D) ;
+1 NEW L
+2 SET L=$PIECE($GET(^DD(F,D,21,0)),U,3)
+3 IF L
Begin DoDot:1
+4 DO BN
+5 NEW I
FOR I=1:1:L
SET DIHELP=DIHELP+1
SET ^TMP("DIHELP",$JOB,DIHELP)=^DD(F,D,21,I,0)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
PXREFS(DIEHF,DIEHFLD) ;
+1 NEW DIF,DIFD,DIEHROOT,DIEHIXID,DIEHIXP,DIEHIXNM,DIFULL
+2 SET DIEHIXP=$$FILENM^DIEFU(DIEHF)_" "
+3 DO GETIXNM(DIEHF,.DIEHIXNM)
+4 SET DIF=""
+5 FOR
SET DIF=$ORDER(DIEHIXNM(DIF))
if DIF=""
QUIT
Begin DoDot:1
+6 SET DIFD=""
+7 FOR
SET DIFD=$ORDER(DIEHIXNM(DIF,DIFD))
if DIFD=""
QUIT
Begin DoDot:2
+8 IF $LENGTH(DIEHIXP)+$LENGTH(DIEHIXNM(DIF,DIFD))>240
Begin DoDot:3
+9 SET DIEHIXP=DIEHIXP_", etc "
+10 SET DIFULL=1
End DoDot:3
QUIT
+11 SET DIEHIXP=DIEHIXP_DIEHIXNM(DIF,DIFD)_", or "
End DoDot:2
if $DATA(DIFULL)
QUIT
End DoDot:1
if $DATA(DIFULL)
QUIT
+12 SET DIEHIXP=$EXTRACT(DIEHIXP,1,$LENGTH(DIEHIXP)-5)
+13 DO BLD^DIALOG(9105,DIEHIXP)
+14 QUIT
+15 ;
GETIXNM(DIEHF,DIEHIXNM) ;
+1 SET DIEHROOT=$$ROOT^DIQGU(DIEHF,"",1)
+2 SET DIEHIXID="Az"
+3 FOR
SET DIEHIXID=$ORDER(@DIEHROOT@(DIEHIXID))
if DIEHIXID=""
QUIT
Begin DoDot:1
+4 NEW DIEHIXF,DIEHIXFD
+5 SET DIEHIXF=$ORDER(^DD(DIEHF,0,"IX",DIEHIXID,""))
if DIEHIXF=""
QUIT
+6 SET DIEHIXFD=$ORDER(^DD(DIEHF,0,"IX",DIEHIXID,DIEHIXF,""))
if DIEHIXFD=""
QUIT
+7 SET DIEHIXNM(DIEHIXF,DIEHIXFD)=$$FLDNM^DIEFU(DIEHIXF,DIEHIXFD)
End DoDot:1
+8 QUIT
+9 ;
SCRNDES(F,D) ;
+1 NEW T
+2 SET T=$GET(^DD(F,D,12))
+3 IF $LENGTH(T)
Begin DoDot:1
+4 DO BN
+5 SET DIHELP=DIHELP+1
SET ^TMP("DIHELP",$JOB,DIHELP)=T
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
SCRNCD(F,D,DIEHZ) ;
+1 NEW S,DIC,Y,A,T,I
+2 IF $PIECE(DIEHZ,U,2)'["*"
DO UNSCRNCD(DIEHZ)
QUIT
+3 SET S=$GET(^DD(F,D,12.1))
+4 IF S=""
DO UNSCRNCD(DIEHZ)
QUIT
+5 DO CODES
+6 IF $DATA(Y)
Begin DoDot:1
+7 NEW DIEHECNT
SET DIEHECNT=$GET(DIERR)
+8 DO SETSCR^DIR(F,D)
+9 DO BLD^DIALOG(9101)
+10 FOR I=1:1:T
Begin DoDot:2
+11 SET Y=$PIECE(Y(I),";",1)
+12 XECUTE DIC("S")
IF $TEST
DO CODESOUT
End DoDot:2
+13 IF DIEHECNT'=$GET(DIERR)
DO HKERR^DILIBF(F,"",D,"set of codes screen")
End DoDot:1
+14 QUIT
UNSCRNCD(DIEHZ) ;
+1 NEW Y,A,T,I
+2 DO CODES
+3 IF $DATA(Y)
Begin DoDot:1
+4 DO BLD^DIALOG(9101)
+5 FOR I=1:1:T
DO CODESOUT
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
CODES ;
+1 ;NAKED
SET A=$PIECE(DIEHZ,U,3)
IF $GET(DUZ("LANG"))>1
IF A=$PIECE(^DD(DIEHF,DIEHFLD,0),U,3)
SET A=$$SETIN^DIALOGZ_";"
+2 IF A]""
Begin DoDot:1
+3 SET T=$LENGTH(A,";")-1
+4 FOR I=1:1:T
SET Y(I)=$PIECE(A,";",I)
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
CODESOUT ;
+1 SET DIHELP=DIHELP+1
SET ^TMP("DIHELP",$JOB,DIHELP)=$PIECE(Y(I),":",1)_" "_$PIECE(Y(I),":",2)
+2 QUIT
+3 ;
VPMSG(F,D) ;
+1 NEW I,N,P,L
+2 DO BLD^DIALOG(9103)
+3 SET I=0
FOR
SET I=$ORDER(^DD(F,D,"V",I))
if I="B"
QUIT
SET N=^(I,0)
Begin DoDot:1
+4 SET P(1)=$PIECE(N,U,4)
SET P(2)=$PIECE(N,U,2)
SET L=$SELECT(I=1:"",1:"S")
+5 DO BLD^DIALOG(9117,.P,.P,"",L)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
FOLLOW(DIEHPF,DIEHUFLG) ;
+1 DO GET(DIEHPF,"",.01,DIEHUFLG_"r")
+2 QUIT
