- DIC2 ;SF/XAK/TKW-LOOKUP (CONT) ;06:31 PM 7 Aug 2002
- ;;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.
- ;
- WO ; Display .01 field, Primary KEY values and Identifiers for an entry.
- I '$D(DST) N DST
- S DST=$G(DST)_" " D WR
- I $D(DIC("W")),$D(@(DIC_"Y,0)")) D:$D(DDS)&'$D(DDH("ID")) ID^DICQ1 I '$D(DDS) D
- . I $G(DST)]"" W DST," "
- . N DISAVEX M DISAVEX=Y N Y M Y=DISAVEX S DISAVEX=X N X S X=DISAVEX K DISAVEX
- . I $D(@(DIC_"Y,0)")) X DIC("W")
- . K DST Q
- Q
- WR ; Put .01 field into DST for display
- D:'$D(DO) GETFA^DIC1(.DIC,.DO) I '$D(DST) N DST
- I (DIC(0)["S"!(DIC(0)["s")),DIVAL(1)'=" " Q:" "[$G(DST)&('$D(DIX("K"))) D S Q
- S DST=$G(DST)
- I DO(2)["V",DIY?1.N1";"1.E S DST=DST_$$EXT(+DO(2),.01,DIY) D S Q
- I DIY?.N.1".".N,(DO(2)["P"!(DO(2)["D")),DIY D D S Q
- . I DO(2)["P" S DST=DST_$$EXT(+DO(2),.01,DIY) Q
- . N % S %=DIY D DT^DIC1 Q
- W1 I '$G(DIYX),DIY]"",((DST'[DIY)!($P(DST,DIY)]"")) S DST=DST_DIY
- S ; Put Primary KEY values into DST, display DST if not in ScreenMan
- I $D(DIX("K")),DIC(0)'["S" N I,F,% F I=0:0 S I=$O(DIX("K",I)) Q:'I F F=0:0 S F=$O(DIX("K",I,F)) Q:'F D
- . I DIY]"",F=.01 Q
- . I $G(DIX("F"))[("^"_F_"^") Q
- . S %=DIX("K",I,F) Q:%="" I $L(%)+$L(DST)>240 Q
- . S DST=DST_$P(" ^",U,DST]"")_% Q
- N A1 S A1=Y I '$D(DDS) W DST K DST Q
- H ; Display .01 and Primary KEY values if in ScreenMan
- I '$D(A1) N A1 S A1="T"
- S DDH=$G(DDH)+1,DDH(DDH,A1)=DST K DST Q
- ;
- EXT(DIFILE,DIFIELD,DIVAL,DIF) ; Return external value of field
- N DIERR,DISAV S DISAV=$G(DIVAL) I DISAV="" Q DISAV
- S DIF=$G(DIF) S:DIF="" DIF="F"
- S DIVAL=$$EXTERNAL^DIDU(DIFILE,DIFIELD,DIF,DIVAL,"DIERR")
- I $D(DIERR) S DIVAL=DISAV
- Q DIVAL
- ;
- PGM(DIC,DF,DIFILE) ; Return special lookup program name
- I DIC(0)["I"!($G(DF)]"") Q ""
- N DIPGM S DIPGM=$G(^DD(DIFILE,0,"DIC")) Q:DIPGM=""!(DIPGM?1"DI".E) ""
- Q U_DIPGM
- ;
- GOT I DIC(0)["E" D
- . N:'$D(DST) DST N DDH D WO
- . I $D(DDS),$D(DDH)>10 D LIST^DDSU K DDH("ID")
- . Q
- S Y=Y_"^"_$S(DIY="":X,$G(DIYX):X_DIY,1:DIY)
- I DIC(0)["E" D Q:Y<0
- . I DO(2)["O"!($G(DIASKOK)) D OK^DIC1 Q
- . Q:DIC(0)'["T"
- . I $G(DICR) Q:'$G(DICRS)!(DICR'=1) D OK^DIC1 Q
- . D OK^DIC1 Q
- R D:'$G(DICR) I Y<0 D A^DIC S DS(0)="1^" Q
- . D ACT^DICM1 Q:Y<0
- . Q:DINDEX("#")'>1!(DINDEX("START")'=DINDEX)
- . N I F I=1:1:DINDEX("#") I $D(DIX(I))#2 S X(I)=DIX(I)
- . Q
- I DIC(0)["Z" S Y(0)=@(DIC_"+Y,0)"),Y(0,0)=$$EXT(DIFILEI,.01,$P(Y(0),U))
- ACT I DIC(0)'["F",$D(DUZ)#2 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_+Y
- I $D(@(DIC_"+Y,0)")) D:DIC(0)'["T" Q Q
- S Y=-1 D Q S DS(0)="1^" Q
- ;
- Q K DIDA,DID,DISMN,DINUM,DS,DF,DD,DIX,DIY,DIYX,DZ,DO,D,DIAC,DIFILE
- I '$G(DICR) K DIC("W"),DIROUT I DIC(0)["T" K ^TMP($J,"DICSEEN")
- Q
- ;
- G ; Display index values for a single looked-up entry
- I $D(DS(0,"DICRS")),'$D(DICRS) N DICRS S DICRS=1
- I $D(DS(0,"DIDA")),'$G(DIDA) N DIDA S DIDA=1
- I $D(DIDA),$P(DS(1),U,2,99)]"" N:'$G(DIASKOK) DIASKOK S DIASKOK=1
- I DIC(0)["T",DIC(0)["E",'$D(DDS) D DSPH^DIC0 W !
- S DIY=1,DIX=X I DIC(0)["E",DIC(0)'["U" D
- . I DIC(0)["D" Q:$P(DS(1,"F"),U,2)=.01 N DIENTIRE S DIENTIRE=1
- . N D,% S (D,%)=""
- . I $G(DIDA),$P(DS(1),U,2,99)]"" S %=" partial match to:"
- . I $O(DS(1,0)) D
- . . I DINDEX("#")=1,'$G(DIDA) S D=%_$$BLDDSP^DIC1(.DS,1,1,.DIYX,.DIY,$G(DICRS)) Q
- . . S D=%_$$BLDDSP^DIC1(.DS,1,"","","",$G(DICRS)) Q
- . E I $G(DITRANX) D
- . . S D=X_$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"")
- . . I $G(DINDEX(1,"TRANOUT"))]"" N X S X=D X DINDEX(1,"TRANOUT") S D=$G(X)
- . . S:D]"" D=" "_D I $G(DIFINDER)["p",'$D(DDS) W !
- . . Q
- . E I '$D(DICRS) D
- . . I $G(DIDA) S D=$P(DS(1),U,2,99) I D]"" S D=%_" "_$$DATE^DIUTL(X_D) W:'$D(DDS) ! Q ;**CCO/NI
- . . S D=$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"")
- . . I $G(DIFINDER)["p" S D=X_D W:'$D(DDS)&(DIC(0)'["T") ! Q
- . . I DIC(0)["T"!($G(DIENTIRE)) S D=X_D
- . . Q
- . S DST=$P(" ^",U,$D(DST)#2)_D
- . I '$D(DDS) W DST S DST=""
- . Q
- C S Y=$G(DIX) M DIX=DS(DIY) S DIX=Y
- I $O(DS(1)) K DIX("F")
- S Y=+DS(DIY),X=X_$P(DS(DIY),"^",2),DIYX=$G(DIYX(DIY)),DIY=DIY(DIY)
- D GOT Q
- ;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIC2 4293 printed Feb 19, 2025@00:11:34 Page 2
- DIC2 ;SF/XAK/TKW-LOOKUP (CONT) ;06:31 PM 7 Aug 2002
- +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 ;
- WO ; Display .01 field, Primary KEY values and Identifiers for an entry.
- +1 IF '$DATA(DST)
- NEW DST
- +2 SET DST=$GET(DST)_" "
- DO WR
- +3 IF $DATA(DIC("W"))
- IF $DATA(@(DIC_"Y,0)"))
- if $DATA(DDS)&'$DATA(DDH("ID"))
- DO ID^DICQ1
- IF '$DATA(DDS)
- Begin DoDot:1
- +4 IF $GET(DST)]""
- WRITE DST," "
- +5 NEW DISAVEX
- MERGE DISAVEX=Y
- NEW Y
- MERGE Y=DISAVEX
- SET DISAVEX=X
- NEW X
- SET X=DISAVEX
- KILL DISAVEX
- +6 IF $DATA(@(DIC_"Y,0)"))
- XECUTE DIC("W")
- +7 KILL DST
- QUIT
- End DoDot:1
- +8 QUIT
- WR ; Put .01 field into DST for display
- +1 if '$DATA(DO)
- DO GETFA^DIC1(.DIC,.DO)
- IF '$DATA(DST)
- NEW DST
- +2 IF (DIC(0)["S"!(DIC(0)["s"))
- IF DIVAL(1)'=" "
- if " "[$GET(DST)&('$DATA(DIX("K")))
- QUIT
- DO S
- QUIT
- +3 SET DST=$GET(DST)
- +4 IF DO(2)["V"
- IF DIY?1.N1";"1.E
- SET DST=DST_$$EXT(+DO(2),.01,DIY)
- DO S
- QUIT
- +5 IF DIY?.N.1".".N
- IF (DO(2)["P"!(DO(2)["D"))
- IF DIY
- Begin DoDot:1
- +6 IF DO(2)["P"
- SET DST=DST_$$EXT(+DO(2),.01,DIY)
- QUIT
- +7 NEW %
- SET %=DIY
- DO DT^DIC1
- QUIT
- End DoDot:1
- DO S
- QUIT
- W1 IF '$GET(DIYX)
- IF DIY]""
- IF ((DST'[DIY)!($PIECE(DST,DIY)]""))
- SET DST=DST_DIY
- S ; Put Primary KEY values into DST, display DST if not in ScreenMan
- +1 IF $DATA(DIX("K"))
- IF DIC(0)'["S"
- NEW I,F,%
- FOR I=0:0
- SET I=$ORDER(DIX("K",I))
- if 'I
- QUIT
- FOR F=0:0
- SET F=$ORDER(DIX("K",I,F))
- if 'F
- QUIT
- Begin DoDot:1
- +2 IF DIY]""
- IF F=.01
- QUIT
- +3 IF $GET(DIX("F"))[("^"_F_"^")
- QUIT
- +4 SET %=DIX("K",I,F)
- if %=""
- QUIT
- IF $LENGTH(%)+$LENGTH(DST)>240
- QUIT
- +5 SET DST=DST_$PIECE(" ^",U,DST]"")_%
- QUIT
- End DoDot:1
- +6 NEW A1
- SET A1=Y
- IF '$DATA(DDS)
- WRITE DST
- KILL DST
- QUIT
- H ; Display .01 and Primary KEY values if in ScreenMan
- +1 IF '$DATA(A1)
- NEW A1
- SET A1="T"
- +2 SET DDH=$GET(DDH)+1
- SET DDH(DDH,A1)=DST
- KILL DST
- QUIT
- +3 ;
- EXT(DIFILE,DIFIELD,DIVAL,DIF) ; Return external value of field
- +1 NEW DIERR,DISAV
- SET DISAV=$GET(DIVAL)
- IF DISAV=""
- QUIT DISAV
- +2 SET DIF=$GET(DIF)
- if DIF=""
- SET DIF="F"
- +3 SET DIVAL=$$EXTERNAL^DIDU(DIFILE,DIFIELD,DIF,DIVAL,"DIERR")
- +4 IF $DATA(DIERR)
- SET DIVAL=DISAV
- +5 QUIT DIVAL
- +6 ;
- PGM(DIC,DF,DIFILE) ; Return special lookup program name
- +1 IF DIC(0)["I"!($GET(DF)]"")
- QUIT ""
- +2 NEW DIPGM
- SET DIPGM=$GET(^DD(DIFILE,0,"DIC"))
- if DIPGM=""!(DIPGM?1"DI".E)
- QUIT ""
- +3 QUIT U_DIPGM
- +4 ;
- GOT IF DIC(0)["E"
- Begin DoDot:1
- +1 if '$DATA(DST)
- NEW DST
- NEW DDH
- DO WO
- +2 IF $DATA(DDS)
- IF $DATA(DDH)>10
- DO LIST^DDSU
- KILL DDH("ID")
- +3 QUIT
- End DoDot:1
- +4 SET Y=Y_"^"_$SELECT(DIY="":X,$GET(DIYX):X_DIY,1:DIY)
- +5 IF DIC(0)["E"
- Begin DoDot:1
- +6 IF DO(2)["O"!($GET(DIASKOK))
- DO OK^DIC1
- QUIT
- +7 if DIC(0)'["T"
- QUIT
- +8 IF $GET(DICR)
- if '$GET(DICRS)!(DICR'=1)
- QUIT
- DO OK^DIC1
- QUIT
- +9 DO OK^DIC1
- QUIT
- End DoDot:1
- if Y<0
- QUIT
- R if '$GET(DICR)
- Begin DoDot:1
- +1 DO ACT^DICM1
- if Y<0
- QUIT
- +2 if DINDEX("#")'>1!(DINDEX("START")'=DINDEX)
- QUIT
- +3 NEW I
- FOR I=1:1:DINDEX("#")
- IF $DATA(DIX(I))#2
- SET X(I)=DIX(I)
- +4 QUIT
- End DoDot:1
- IF Y<0
- DO A^DIC
- SET DS(0)="1^"
- QUIT
- +5 IF DIC(0)["Z"
- SET Y(0)=@(DIC_"+Y,0)")
- SET Y(0,0)=$$EXT(DIFILEI,.01,$PIECE(Y(0),U))
- ACT IF DIC(0)'["F"
- IF $DATA(DUZ)#2
- SET ^DISV(DUZ,$EXTRACT(DIC,1,28))=$EXTRACT(DIC,29,999)_+Y
- +1 IF $DATA(@(DIC_"+Y,0)"))
- if DIC(0)'["T"
- DO Q
- QUIT
- +2 SET Y=-1
- DO Q
- SET DS(0)="1^"
- QUIT
- +3 ;
- Q KILL DIDA,DID,DISMN,DINUM,DS,DF,DD,DIX,DIY,DIYX,DZ,DO,D,DIAC,DIFILE
- +1 IF '$GET(DICR)
- KILL DIC("W"),DIROUT
- IF DIC(0)["T"
- KILL ^TMP($JOB,"DICSEEN")
- +2 QUIT
- +3 ;
- G ; Display index values for a single looked-up entry
- +1 IF $DATA(DS(0,"DICRS"))
- IF '$DATA(DICRS)
- NEW DICRS
- SET DICRS=1
- +2 IF $DATA(DS(0,"DIDA"))
- IF '$GET(DIDA)
- NEW DIDA
- SET DIDA=1
- +3 IF $DATA(DIDA)
- IF $PIECE(DS(1),U,2,99)]""
- if '$GET(DIASKOK)
- NEW DIASKOK
- SET DIASKOK=1
- +4 IF DIC(0)["T"
- IF DIC(0)["E"
- IF '$DATA(DDS)
- DO DSPH^DIC0
- WRITE !
- +5 SET DIY=1
- SET DIX=X
- IF DIC(0)["E"
- IF DIC(0)'["U"
- Begin DoDot:1
- +6 IF DIC(0)["D"
- if $PIECE(DS(1,"F"),U,2)=.01
- QUIT
- NEW DIENTIRE
- SET DIENTIRE=1
- +7 NEW D,%
- SET (D,%)=""
- +8 IF $GET(DIDA)
- IF $PIECE(DS(1),U,2,99)]""
- SET %=" partial match to:"
- +9 IF $ORDER(DS(1,0))
- Begin DoDot:2
- +10 IF DINDEX("#")=1
- IF '$GET(DIDA)
- SET D=%_$$BLDDSP^DIC1(.DS,1,1,.DIYX,.DIY,$GET(DICRS))
- QUIT
- +11 SET D=%_$$BLDDSP^DIC1(.DS,1,"","","",$GET(DICRS))
- QUIT
- End DoDot:2
- +12 IF '$TEST
- IF $GET(DITRANX)
- Begin DoDot:2
- +13 SET D=X_$PIECE(DS(1),U,2,99)_$SELECT($GET(DIYX(1)):$GET(DIY(1)),1:"")
- +14 IF $GET(DINDEX(1,"TRANOUT"))]""
- NEW X
- SET X=D
- XECUTE DINDEX(1,"TRANOUT")
- SET D=$GET(X)
- +15 if D]""
- SET D=" "_D
- IF $GET(DIFINDER)["p"
- IF '$DATA(DDS)
- WRITE !
- +16 QUIT
- End DoDot:2
- +17 IF '$TEST
- IF '$DATA(DICRS)
- Begin DoDot:2
- +18 ;**CCO/NI
- IF $GET(DIDA)
- SET D=$PIECE(DS(1),U,2,99)
- IF D]""
- SET D=%_" "_$$DATE^DIUTL(X_D)
- if '$DATA(DDS)
- WRITE !
- QUIT
- +19 SET D=$PIECE(DS(1),U,2,99)_$SELECT($GET(DIYX(1)):$GET(DIY(1)),1:"")
- +20 IF $GET(DIFINDER)["p"
- SET D=X_D
- if '$DATA(DDS)&(DIC(0)'["T")
- WRITE !
- QUIT
- +21 IF DIC(0)["T"!($GET(DIENTIRE))
- SET D=X_D
- +22 QUIT
- End DoDot:2
- +23 SET DST=$PIECE(" ^",U,$DATA(DST)#2)_D
- +24 IF '$DATA(DDS)
- WRITE DST
- SET DST=""
- +25 QUIT
- End DoDot:1
- C SET Y=$GET(DIX)
- MERGE DIX=DS(DIY)
- SET DIX=Y
- +1 IF $ORDER(DS(1))
- KILL DIX("F")
- +2 SET Y=+DS(DIY)
- SET X=X_$PIECE(DS(DIY),"^",2)
- SET DIYX=$GET(DIYX(DIY))
- SET DIY=DIY(DIY)
- +3 DO GOT
- QUIT
- +4 ;
- +5 ;
