Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DICF4

DICF4.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ;
  1. ; PREPIX^DICF2--transform value for indexed pointer field
  1. N DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW
  1. S DIF=$TR(DIFLAGS,$TR(DIFLAGS,"4XOB"))_"Mp",DIX="B"
  1. I DIFLAGS["B" S DIF=$TR(DIF,"M")
  1. D GETTMP^DICUIX1(.DITARGET,"DICF")
  1. S DITARGET("C")=0
  1. S (DIPRV,DINEW)="S" F S DINEW=$O(DISCREEN(DINEW)) Q:$E(DINEW)'="S" S DIPRV=DINEW,DISCR(DIPRV)=DISCREEN(DIPRV)
  1. S DINEW="S"_($P(DIPRV,"S",2)+1)
  1. P1 ; Process regular pointer
  1. I DINDEX(1,"TYPE")="P" D Q
  1. . S DIFL=+$P($P(DINDEX(1,"NODE"),U,2),"P",2) Q:'DIFL
  1. . M DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1)
  1. . I DIFLAGS["l" D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
  1. . I DIFLAGS'["l" D
  1. 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
  1. . . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF)
  1. . . N F S F=DIF N DIF S DIF=F K F M DIFL("CHAIN")=DIFILE("CHAIN")
  1. . . D BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
  1. . . D FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET)
  1. . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
  1. . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
  1. . Q
  1. P2 ; Process variable pointer
  1. I DIFLAGS["l" D Q
  1. . D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET)
  1. . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
  1. . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
  1. . Q
  1. N DIFILES I DIVALUE(1)[".",$P(DIVALUE(1),".")]"" D
  1. . N V S V=$$OUT^DIALOGU($P(DIVALUE(1),"."),"UC")
  1. . D VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES)
  1. . Q
  1. P21 D P3 I $G(DIERR) K @DITARGET Q
  1. I $O(DIFILES(0)),'$G(@DITARGET) K DIFILES D P3
  1. I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q
  1. S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B"))
  1. Q
  1. ;
  1. P3 N DIVP,G,I,X,DIF1,DIS1
  1. 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)
  1. . K DIF1,DIFL,DIPVAL,DIS1,DIX S DIX="B"
  1. . Q:'X I $O(DIFILES(0)) Q:'$D(DIFILES(+X))
  1. . I $G(DISCREEN("V",1))]"" D Q:G=""
  1. . . S G=$G(^DIC(+X,0,"GL")) Q:G=""
  1. . . S:'$D(DINDEX(DISUB,"VP",G)) G="" Q
  1. . S DIF1=DIF_"v",DIFL=+X
  1. . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1)
  1. . D FILE^DICUF(.DIFL,"",.DIF1) Q:$G(DIERR)
  1. . M DIS1=DISCR
  1. . I '$O(DIFILES(0)) M DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1)
  1. . E D
  1. . . S DIF1=DIF1_"t"
  1. . . S DIPVAL(1)=$P(DIVALUE(1),".",2,99)
  1. . . Q
  1. . M DIFL("CHAIN")=DIFILE("CHAIN")
  1. . D BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE)
  1. . S DITARGET("C")=+$G(@DITARGET)
  1. . D FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET)
  1. . Q
  1. Q
  1. ;
  1. SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them.
  1. M DIX("PTRIX")=DIFORCE("PTRIX") N %
  1. S %=$G(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL))
  1. Q:%="" S DIX=%
  1. I $P(DIX,U,2)="" S:DIF["M" DIF=$TR(DIF,"M") Q
  1. S:DIF'["M" DIF=DIF_"M" Q
  1. ;
  1. BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index.
  1. N DICSUBS S DICSUBS=""
  1. S DISCR(DINEW)=$S(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T")
  1. N I S I="I" S:DINDEX(1,"TYPE")["V" I=I_"_"";"_$P(DIFL(DIFL,"O"),U,2)_""""
  1. S DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")"
  1. I DINDEX("#")>1 D Q
  1. . S DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW)
  1. . Q
  1. 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)
  1. Q
  1. ;
  1. SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1).
  1. N %,DICODE S DICODE="S DA="_+$G(DIEN(1))
  1. F %=1:1 Q:'$D(DIEN(%)) S DICODE=DICODE_",DA("_%_")="_DIEN(%)
  1. Q DICODE
  1. ;
  1. DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there.
  1. N %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER
  1. S DO(2)=DIFILE,(D,DF)=DINDEX("START"),(X,DIVAL(1))=DIVALUE(1),DIVAL(0)=1
  1. S DD=0,%=DINDEX,DS=$G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),Y=DINDEX(1,"TYPE"),%Y=DINDEX(1,"FIELD")
  1. S:$G(DICR)="" DICR=0
  1. D
  1. . N DIFILE,I
  1. . S DIFINDER="p"
  1. . M I=DIC N DIC M DIC=I K I
  1. . N DA X $$SETDA(.DIEN) N DIEN
  1. . D A^DICM Q:Y=-1 D ^DICM1 K DICR(DICR) S DICR=DICR-1 I DICR<1 K DICR
  1. . Q
  1. Q:Y'>0
  1. S @DITARGET@("B",($P(Y,U,2)_U_X))="",@DITARGET=1
  1. Q
  1. ;
  1. ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ;
  1. ; error logging procedure
  1. N DIPE
  1. N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI))
  1. D BLD^DIALOG(DIERN,.DIPE,.DIPE)
  1. Q
  1. ;