DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;24MAY2008
;;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.
;
NODE75 ; Do after executing 7.5 node on DD, called from ^DIC
I $D(X)#2 S (DIVAL,DIVAL(1))=X Q
S Y=-1 Q:DIC(0)'["Q"!(DIC(0)'["E")
W $C(7) Q:$D(DDS)
W !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090)) Q
;
BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC
S Y=$E(X,2,30) I Y="" S Y=-1 Q
N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=%
D S^DIC3 I '$T S Y=-1 Q
N DD,DS,DZ S DS=1,DD=Y,DIX=X D ADDKEY^DIC3,GOT^DIC2
Q
;
BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC
Q:DO(2)<0!($D(DF))
N T S T=DINDEX(1,"TYPE")
I $D(@(DIC_"X,0)")) D Q:Y>0
. N DD S DD=$D(^DD(DIFILEI,.001))
. I 'DD Q:T["N" I '$O(@(DIC_"""A["")")),$O(^("A["))]"" Q
. N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=%
. S Y=X D S^DIC3 I '$T S Y=-1 Q
. N DZ,DS,DIX,DIC5D S DIC5D=D,DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q:Y>0
. D DO^DIC1 S D=DIC5D
I T["P"!(T["V"),DIC(0)'["U" S DISKIPIX=D
Q
;
SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC
N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=%
D S^DIC3 I '$T S Y=-1 Q
N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q
;
KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3.
I DS D Q:Y>0!($G(DTOUT))!($G(DIROUT))
. N I M I=X N X M X=I S I=D N D S D=I K I
. I DS=1 D
. . S DS("DD")=1 D G^DIC2 Q
. E I $G(DS("DD"))'=DS D Y^DIC1 I '$D(DIROUT),$D(DUOUT) K DUOUT ;22*70
. K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0
. S:DIC(0)["E" DS(0,"HDRDSP",DIFILEI)=1
. S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0)
. Q
Q:DIC(0)["U" I DINDEX=DINDEX("START"),$G(DINDEX("#"))>1 Q
N I M I=X N X M X=I S I=D N D S D=I K I
D 1^DICM
K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0
S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0)
Q
;
PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files
N DIFILEI,DIGBL,DIOGBL S DIFILEI=+DO(2),DIOGBL=DIC
F S DIFILEI=+$P($P($G(^DD(DIFILEI,.01,0)),U,2),"P",2) Q:'DIFILEI S DIGBL=$G(^DIC(DIFILEI,0,"GL")) Q:DIGBL="" D Q
Q
Q ; Build Identifier code for a single pointed-to file
N DIGBL1 S DIGBL1=DIGBL
I DIGBL[$C(34) S DIGBL1=$$CONVQQ^DILIBF(DIGBL)
N N,O,% S N=$O(DIC("W",999999),-1)
S O=$S(N:DIC("W",N),1:DIC("W"))
N % S %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1"
S DIOGBL=DIGBL
I ($L(O)+$L(%))<230 D Q
. I 'N S DIC("W")=DIC("W")_" "_% Q
. S DIC("W",N)=DIC("W",N)_" "_% Q
S N=N+1,DIC("W",N)=%
I N=1 S DIC("W")=DIC("W")_" X DIC(""W"",1)" Q
S DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIC5 3235 printed Oct 16, 2024@18:45:56 Page 2
DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;24MAY2008
+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 ;
NODE75 ; Do after executing 7.5 node on DD, called from ^DIC
+1 IF $DATA(X)#2
SET (DIVAL,DIVAL(1))=X
QUIT
+2 SET Y=-1
if DIC(0)'["Q"!(DIC(0)'["E")
QUIT
+3 WRITE $CHAR(7)
if $DATA(DDS)
QUIT
+4 WRITE !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090))
QUIT
+5 ;
BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC
+1 SET Y=$EXTRACT(X,2,30)
IF Y=""
SET Y=-1
QUIT
+2 NEW %
SET %=DINDEX("START")
NEW DINDEX
SET DINDEX=""
SET DINDEX("#")=1
SET DINDEX("START")=%
+3 DO S^DIC3
IF '$TEST
SET Y=-1
QUIT
+4 NEW DD,DS,DZ
SET DS=1
SET DD=Y
SET DIX=X
DO ADDKEY^DIC3
DO GOT^DIC2
+5 QUIT
+6 ;
BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC
+1 if DO(2)<0!($DATA(DF))
QUIT
+2 NEW T
SET T=DINDEX(1,"TYPE")
+3 IF $DATA(@(DIC_"X,0)"))
Begin DoDot:1
+4 NEW DD
SET DD=$DATA(^DD(DIFILEI,.001))
+5 IF 'DD
if T["N"
QUIT
IF '$ORDER(@(DIC_"""A["")"))
IF $ORDER(^("A["))]""
QUIT
+6 NEW %
SET %=DINDEX("START")
NEW DINDEX
SET DINDEX=""
SET DINDEX("#")=1
SET DINDEX("START")=%
+7 SET Y=X
DO S^DIC3
IF '$TEST
SET Y=-1
QUIT
+8 NEW DZ,DS,DIX,DIC5D
SET DIC5D=D
SET DS=1
SET DIX=X
DO ADDKEY^DIC3
DO GOT^DIC2
if Y>0
QUIT
+9 DO DO^DIC1
SET D=DIC5D
End DoDot:1
if Y>0
QUIT
+10 IF T["P"!(T["V")
IF DIC(0)'["U"
SET DISKIPIX=D
+11 QUIT
+12 ;
SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC
+1 NEW %
SET %=DINDEX("START")
NEW DINDEX
SET DINDEX=""
SET DINDEX("#")=1
SET DINDEX("START")=%
+2 DO S^DIC3
IF '$TEST
SET Y=-1
QUIT
+3 NEW DZ,DS,DIX
SET DS=1
SET DIX=X
DO ADDKEY^DIC3
DO GOT^DIC2
QUIT
+4 ;
KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3.
+1 IF DS
Begin DoDot:1
+2 NEW I
MERGE I=X
NEW X
MERGE X=I
SET I=D
NEW D
SET D=I
KILL I
+3 IF DS=1
Begin DoDot:2
+4 SET DS("DD")=1
DO G^DIC2
QUIT
End DoDot:2
+5 ;22*70
IF '$TEST
IF $GET(DS("DD"))'=DS
DO Y^DIC1
IF '$DATA(DIROUT)
IF $DATA(DUOUT)
KILL DUOUT
+6 KILL DD,DS,DIX,DIYX
SET (DD,DS,DS("DD"))=0
+7 if DIC(0)["E"
SET DS(0,"HDRDSP",DIFILEI)=1
+8 SET DS(0)=$SELECT(Y>0:"1^"_+Y,$GET(DTOUT):"1^T",$GET(DIROUT):"1^U",1:0)
+9 QUIT
End DoDot:1
if Y>0!($GET(DTOUT))!($GET(DIROUT))
QUIT
+10 if DIC(0)["U"
QUIT
IF DINDEX=DINDEX("START")
IF $GET(DINDEX("#"))>1
QUIT
+11 NEW I
MERGE I=X
NEW X
MERGE X=I
SET I=D
NEW D
SET D=I
KILL I
+12 DO 1^DICM
+13 KILL DD,DS,DIX,DIYX
SET (DD,DS,DS("DD"))=0
+14 SET DS(0)=$SELECT(Y>0:"1^"_+Y,$GET(DTOUT):"1^T",$GET(DIROUT):"1^U",1:0)
+15 QUIT
+16 ;
PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files
+1 NEW DIFILEI,DIGBL,DIOGBL
SET DIFILEI=+DO(2)
SET DIOGBL=DIC
+2 FOR
SET DIFILEI=+$PIECE($PIECE($GET(^DD(DIFILEI,.01,0)),U,2),"P",2)
if 'DIFILEI
QUIT
SET DIGBL=$GET(^DIC(DIFILEI,0,"GL"))
if DIGBL=""
QUIT
DO Q
+3 QUIT
Q ; Build Identifier code for a single pointed-to file
+1 NEW DIGBL1
SET DIGBL1=DIGBL
+2 IF DIGBL[$CHAR(34)
SET DIGBL1=$$CONVQQ^DILIBF(DIGBL)
+3 NEW N,O,%
SET N=$ORDER(DIC("W",999999),-1)
+4 SET O=$SELECT(N:DIC("W",N),1:DIC("W"))
+5 NEW %
SET %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1"
+6 SET DIOGBL=DIGBL
+7 IF ($LENGTH(O)+$LENGTH(%))<230
Begin DoDot:1
+8 IF 'N
SET DIC("W")=DIC("W")_" "_%
QUIT
+9 SET DIC("W",N)=DIC("W",N)_" "_%
QUIT
End DoDot:1
QUIT
+10 SET N=N+1
SET DIC("W",N)=%
+11 IF N=1
SET DIC("W")=DIC("W")_" X DIC(""W"",1)"
QUIT
+12 SET DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")"
+13 QUIT
+14 ;
