- 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 Feb 19, 2025@00:11:37 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 ;
