- DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;2014-12-12 12:14 PM
- ;;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.
- ;
- POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ;
- ; PREPIX^DICF2--transform value for indexed pointer field
- N DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW
- S DIF=$TR(DIFLAGS,$TR(DIFLAGS,"4XOB"))_"Mp",DIX="B"
- I DIFLAGS["B" S DIF=$TR(DIF,"M")
- D GETTMP^DICUIX1(.DITARGET,"DICF")
- S DITARGET("C")=0
- S (DIPRV,DINEW)="S" F S DINEW=$O(DISCREEN(DINEW)) Q:$E(DINEW)'="S" S DIPRV=DINEW,DISCR(DIPRV)=DISCREEN(DIPRV)
- S DINEW="S"_($P(DIPRV,"S",2)+1)
- P1 ; Process regular pointer
- I DINDEX(1,"TYPE")="P" D Q
- . S DIFL=+$P($P(DINDEX(1,"NODE"),U,2),"P",2) Q:'DIFL
- . M DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1)
- . I DIFLAGS["l" D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
- . I DIFLAGS'["l" D
- NUM ..;I +$P(DIPVAL(1),"E")=DIPVAL(1),$G(DINDEX)'="B",DIFLAGS["M" Q ;GFT PATCH 165 DO NOT LOOK UP POINTERS. IN 1040 DID NOT HAVE ,$G(DINDEX)'="B",DIFLAGS["M"
- . . ; DI*22*169 (mko): Commented out line above to allow the use of indexes on the pointed-to file
- . . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF)
- . . N F S F=DIF N DIF S DIF=F K F M DIFL("CHAIN")=DIFILE("CHAIN")
- . . D BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
- . . D FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET)
- . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
- . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
- . Q
- P2 ; Process variable pointer
- I DIFLAGS["l" D Q
- . D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
- . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
- . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
- . Q
- N DIFILES I DIVALUE(1)[".",$P(DIVALUE(1),".")]"" D
- . N V S V=$$OUT^DIALOGU($P(DIVALUE(1),"."),"UC")
- . D VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES)
- . Q
- P21 D P3 I $G(DIERR) K @DITARGET Q
- I $O(DIFILES(0)),'$G(@DITARGET) K DIFILES D P3
- I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
- S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
- Q
- ;
- P3 N DIVP,G,I,X,DIF1,DIS1
- F DIVP=0:0 S DIVP=$O(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),"V",DIVP)) Q:'DIVP S X=$G(^(DIVP,0)) D Q:$G(DIERR)
- . K DIF1,DIFL,DIPVAL,DIS1,DIX S DIX="B"
- . Q:'X I $O(DIFILES(0)) Q:'$D(DIFILES(+X))
- . I $G(DISCREEN("V",1))]"" D Q:G=""
- . . S G=$G(^DIC(+X,0,"GL")) Q:G=""
- . . S:'$D(DINDEX(DISUB,"VP",G)) G="" Q
- . S DIF1=DIF_"v",DIFL=+X
- . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1)
- . D FILE^DICUF(.DIFL,"",.DIF1) Q:$G(DIERR)
- . M DIS1=DISCR
- . I '$O(DIFILES(0)) M DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1)
- . E D
- . . S DIF1=DIF1_"t"
- . . S DIPVAL(1)=$P(DIVALUE(1),".",2,99)
- . . Q
- . M DIFL("CHAIN")=DIFILE("CHAIN")
- . D BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
- . S DITARGET("C")=+$G(@DITARGET)
- . D FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET)
- . Q
- Q
- ;
- SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them.
- M DIX("PTRIX")=DIFORCE("PTRIX") N %
- S %=$G(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL))
- Q:%="" S DIX=%
- I $P(DIX,U,2)="" S:DIF["M" DIF=$TR(DIF,"M") Q
- S:DIF'["M" DIF=DIF_"M" Q
- ;
- BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index.
- N DICSUBS S DICSUBS=""
- S DISCR(DINEW)=$S(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T")
- N I S I="I" S:DINDEX(1,"TYPE")["V" I=I_"_"";"_$P(DIFL(DIFL,"O"),U,2)_""""
- S DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")"
- I DINDEX("#")>1 D Q
- . S DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW)
- . Q
- S DISCR(DINEW)="X ""I 0"" N I F I=0:0 S I=$O("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_",I)) Q:'I I $D("_DIFILE(DIFILE,"O")_"I,0))"_DISCR(DINEW)
- Q
- ;
- SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1).
- N %,DICODE S DICODE="S DA="_+$G(DIEN(1))
- F %=1:1 Q:'$D(DIEN(%)) S DICODE=DICODE_",DA("_%_")="_DIEN(%)
- Q DICODE
- ;
- DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there.
- N %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER
- S DO(2)=DIFILE,(D,DF)=DINDEX("START"),(X,DIVAL(1))=DIVALUE(1),DIVAL(0)=1
- S DD=0,%=DINDEX,DS=$G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),Y=DINDEX(1,"TYPE"),%Y=DINDEX(1,"FIELD")
- S:$G(DICR)="" DICR=0
- D
- . N DIFILE,I
- . S DIFINDER="p"
- . M I=DIC N DIC M DIC=I K I
- . N DA X $$SETDA(.DIEN) N DIEN
- . D A^DICM Q:Y=-1 D ^DICM1 K DICR(DICR) S DICR=DICR-1 I DICR<1 K DICR
- . Q
- Q:Y'>0
- S @DITARGET@("B",($P(Y,U,2)_U_X))="",@DITARGET=1
- Q
- ;
- ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
- ; error logging procedure
- N DIPE
- N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
- D BLD^DIALOG(DIERN,.DIPE,.DIPE)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICF4 5320 printed Feb 19, 2025@00:12:19 Page 2
- DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;2014-12-12 12:14 PM
- +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 ;
- POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ;
- +1 ; PREPIX^DICF2--transform value for indexed pointer field
- +2 NEW DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW
- +3 SET DIF=$TRANSLATE(DIFLAGS,$TRANSLATE(DIFLAGS,"4XOB"))_"Mp"
- SET DIX="B"
- +4 IF DIFLAGS["B"
- SET DIF=$TRANSLATE(DIF,"M")
- +5 DO GETTMP^DICUIX1(.DITARGET,"DICF")
- +6 SET DITARGET("C")=0
- +7 SET (DIPRV,DINEW)="S"
- FOR
- SET DINEW=$ORDER(DISCREEN(DINEW))
- if $EXTRACT(DINEW)'="S"
- QUIT
- SET DIPRV=DINEW
- SET DISCR(DIPRV)=DISCREEN(DIPRV)
- +8 SET DINEW="S"_($PIECE(DIPRV,"S",2)+1)
- P1 ; Process regular pointer
- +1 IF DINDEX(1,"TYPE")="P"
- Begin DoDot:1
- +2 SET DIFL=+$PIECE($PIECE(DINDEX(1,"NODE"),U,2),"P",2)
- if 'DIFL
- QUIT
- +3 MERGE DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1)
- +4 IF DIFLAGS["l"
- DO DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
- +5 IF DIFLAGS'["l"
- Begin DoDot:2
- NUM ;I +$P(DIPVAL(1),"E")=DIPVAL(1),$G(DINDEX)'="B",DIFLAGS["M" Q ;GFT PATCH 165 DO NOT LOOK UP POINTERS. IN 1040 DID NOT HAVE ,$G(DINDEX)'="B",DIFLAGS["M"
- +1 ; DI*22*169 (mko): Commented out line above to allow the use of indexes on the pointed-to file
- +2 IF $DATA(DIFORCE("PTRIX"))
- DO SETIX(.DIFORCE,.DINDEX,.DIX,.DIF)
- +3 NEW F
- SET F=DIF
- NEW DIF
- SET DIF=F
- KILL F
- MERGE DIFL("CHAIN")=DIFILE("CHAIN")
- +4 DO BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
- +5 DO FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET)
- End DoDot:2
- +6 IF $GET(DIERR)!('$GET(@DITARGET))
- KILL @DITARGET
- QUIT
- +7 SET DINDEX(1,"IXROOT")=DINDEX(1,"ROOT")
- SET DINDEX(1,"ROOT")=$NAME(@DITARGET@("B"))
- +8 QUIT
- End DoDot:1
- QUIT
- P2 ; Process variable pointer
- +1 IF DIFLAGS["l"
- Begin DoDot:1
- +2 DO DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
- +3 IF $GET(DIERR)!('$GET(@DITARGET))
- KILL @DITARGET
- QUIT
- +4 SET DINDEX(1,"IXROOT")=DINDEX(1,"ROOT")
- SET DINDEX(1,"ROOT")=$NAME(@DITARGET@("B"))
- +5 QUIT
- End DoDot:1
- QUIT
- +6 NEW DIFILES
- IF DIVALUE(1)["."
- IF $PIECE(DIVALUE(1),".")]""
- Begin DoDot:1
- +7 NEW V
- SET V=$$OUT^DIALOGU($PIECE(DIVALUE(1),"."),"UC")
- +8 DO VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES)
- +9 QUIT
- End DoDot:1
- P21 DO P3
- IF $GET(DIERR)
- KILL @DITARGET
- QUIT
- +1 IF $ORDER(DIFILES(0))
- IF '$GET(@DITARGET)
- KILL DIFILES
- DO P3
- +2 IF $GET(DIERR)!('$GET(@DITARGET))
- KILL @DITARGET
- QUIT
- +3 SET DINDEX(1,"IXROOT")=DINDEX(1,"ROOT")
- SET DINDEX(1,"ROOT")=$NAME(@DITARGET@("B"))
- +4 QUIT
- +5 ;
- P3 NEW DIVP,G,I,X,DIF1,DIS1
- +1 FOR DIVP=0:0
- SET DIVP=$ORDER(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),"V",DIVP))
- if 'DIVP
- QUIT
- SET X=$GET(^(DIVP,0))
- Begin DoDot:1
- +2 KILL DIF1,DIFL,DIPVAL,DIS1,DIX
- SET DIX="B"
- +3 if 'X
- QUIT
- IF $ORDER(DIFILES(0))
- if '$DATA(DIFILES(+X))
- QUIT
- +4 IF $GET(DISCREEN("V",1))]""
- Begin DoDot:2
- +5 SET G=$GET(^DIC(+X,0,"GL"))
- if G=""
- QUIT
- +6 if '$DATA(DINDEX(DISUB,"VP",G))
- SET G=""
- QUIT
- End DoDot:2
- if G=""
- QUIT
- +7 SET DIF1=DIF_"v"
- SET DIFL=+X
- +8 IF $DATA(DIFORCE("PTRIX"))
- DO SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1)
- +9 DO FILE^DICUF(.DIFL,"",.DIF1)
- if $GET(DIERR)
- QUIT
- +10 MERGE DIS1=DISCR
- +11 IF '$ORDER(DIFILES(0))
- MERGE DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1)
- +12 IF '$TEST
- Begin DoDot:2
- +13 SET DIF1=DIF1_"t"
- +14 SET DIPVAL(1)=$PIECE(DIVALUE(1),".",2,99)
- +15 QUIT
- End DoDot:2
- +16 MERGE DIFL("CHAIN")=DIFILE("CHAIN")
- +17 DO BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
- +18 SET DITARGET("C")=+$GET(@DITARGET)
- +19 DO FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET)
- +20 QUIT
- End DoDot:1
- if $GET(DIERR)
- QUIT
- +21 QUIT
- +22 ;
- SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them.
- +1 MERGE DIX("PTRIX")=DIFORCE("PTRIX")
- NEW %
- +2 SET %=$GET(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL))
- +3 if %=""
- QUIT
- SET DIX=%
- +4 IF $PIECE(DIX,U,2)=""
- if DIF["M"
- SET DIF=$TRANSLATE(DIF,"M")
- QUIT
- +5 if DIF'["M"
- SET DIF=DIF_"M"
- QUIT
- +6 ;
- BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index.
- +1 NEW DICSUBS
- SET DICSUBS=""
- +2 SET DISCR(DINEW)=$SELECT(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T")
- +3 NEW I
- SET I="I"
- if DINDEX(1,"TYPE")["V"
- SET I=I_"_"";"_$PIECE(DIFL(DIFL,"O"),U,2)_""""
- +4 SET DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")"
- +5 IF DINDEX("#")>1
- Begin DoDot:1
- +6 SET DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW)
- +7 QUIT
- End DoDot:1
- QUIT
- +8 SET DISCR(DINEW)="X ""I 0"" N I F I=0:0 S I=$O("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_",I)) Q:'I I $D("_DIFILE(DIFILE,"O")_"I,0))"_DISCR(DINEW)
- +9 QUIT
- +10 ;
- SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1).
- +1 NEW %,DICODE
- SET DICODE="S DA="_+$GET(DIEN(1))
- +2 FOR %=1:1
- if '$DATA(DIEN(%))
- QUIT
- SET DICODE=DICODE_",DA("_%_")="_DIEN(%)
- +3 QUIT DICODE
- +4 ;
- DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there.
- +1 NEW %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER
- +2 SET DO(2)=DIFILE
- SET (D,DF)=DINDEX("START")
- SET (X,DIVAL(1))=DIVALUE(1)
- SET DIVAL(0)=1
- +3 SET DD=0
- SET %=DINDEX
- SET DS=$GET(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0))
- SET Y=DINDEX(1,"TYPE")
- SET %Y=DINDEX(1,"FIELD")
- +4 if $GET(DICR)=""
- SET DICR=0
- +5 Begin DoDot:1
- +6 NEW DIFILE,I
- +7 SET DIFINDER="p"
- +8 MERGE I=DIC
- NEW DIC
- MERGE DIC=I
- KILL I
- +9 NEW DA
- XECUTE $$SETDA(.DIEN)
- NEW DIEN
- +10 DO A^DICM
- if Y=-1
- QUIT
- DO ^DICM1
- KILL DICR(DICR)
- SET DICR=DICR-1
- IF DICR<1
- KILL DICR
- +11 QUIT
- End DoDot:1
- +12 if Y'>0
- QUIT
- +13 SET @DITARGET@("B",($PIECE(Y,U,2)_U_X))=""
- SET @DITARGET=1
- +14 QUIT
- +15 ;
- ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
- +1 ; error logging procedure
- +2 NEW DIPE
- +3 NEW DI
- FOR DI="FILE","IENS","FIELD",1:1:3
- SET DIPE(DI)=$GET(@("DI"_DI))
- +4 DO BLD^DIALOG(DIERN,.DIPE,.DIPE)
- +5 QUIT
- +6 ;