Return to DICF1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DICF1	;SEA/TOAD-VA FileMan: Finder, Part 2 (Transform) ;11/17/94  12:21 ;
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	
    5: XFORM(DIFLAGS,DIVALUE,DISCREEN,DILVA,DILIST)	
    6: 	; FIND--produce array of values and screens by transforming input
    7: 	; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference
    8: BASIC	
    9: 	N DISNAME S DISNAME="DILVA(""S"")"
   10: 	N DIVNAME S DIVNAME="DILVA(""V"")"
   11: 	S @DIVNAME=DIVALUE
   12: 	S @DISNAME=DISCREEN
   13: SETLONG	
   14: 	N DILONG S DILONG=$S(DIFLAGS["Q":0,1:$L(DIVALUE)>29&(DIFLAGS'["U")*4)
   15: 	I DILONG N DISNAMES S DISNAMES=DISNAME,DISNAME=$NA(@DISNAME@(0))
   16: 	N DISNAMEX S DISNAMEX=$NA(@DILIST("LVA")@("S"))
   17: 	I DILONG S DISNAMEX=$NA(@DISNAMEX@(0))
   18: 	I DILONG N DIVNAMES S DIVNAMES=DIVNAME,DIVNAME=$NA(@DIVNAME@(0))
   19: 	N DIVNAMEX S DIVNAMEX=$NA(@DILIST("LVA")@("V"))
   20: 	I DILONG S DIVNAMEX=$NA(@DIVNAMEX@(0))
   21: 	S @DIVNAME@(1+DILONG)=DIVALUE
   22: 	S @DISNAME@(1+DILONG)=DISCREEN
   23: 	I DIFLAGS["Q" Q
   24: LOWER	
   25: 	I DIVALUE?.E1L.E N DILOWER,DIUPPER D
   26: 	. S DILOWER="abcdefghijklmnopqrstuvwxyz"
   27: 	. S DIUPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   28: 	. N DITEMP S DITEMP=$TR(DIVALUE,DILOWER,DIUPPER)
   29: 	. S @DIVNAME@(2+DILONG)=DITEMP
   30: 	. S @DISNAME@(2+DILONG)=DISCREEN
   31: 	
   32: COMMA	N DIREF I DIVALUE[",",DIFLAGS'["X" D
   33: 	. S DIFLAGS=DIFLAGS_"g"
   34: 	. N DISTEMP S DISTEMP=""
   35: 	. N DIPART1 S DIPART1=" I %?.E1P1"""
   36: 	. N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1"""
   37: 	. N DIPART3 S DIPART3=""".E))"
   38: 	. N DIOUT S DIOUT=0
   39: 21	. N DIPIECE,DIVPIECE F DIPIECE=2:1 D  I DIOUT Q
   40: 	. . S DIVPIECE=$P(DIVALUE,",",DIPIECE)
   41: 	. . I DIVPIECE["""" Q
   42: 	. . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE))
   43: 	. . I DIVPIECE="" S DIOUT=1 Q
   44: 	. . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q
   45: 	. . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3
   46: 22	. I DISTEMP="" Q
   47: 	. S DISTEMP="S %=DIFIELD"_DISTEMP
   48: 	. S DIREF=$NA(@DISNAMEX@(1+DILONG))
   49: 	. N DISOLD I @DIREF="" S DISOLD=""
   50: 	. E  S DISOLD=" X "_DIREF
   51: 	. S @DIVNAME@(3+DILONG)=$P(DIVALUE,",")
   52: 	. S @DISNAME@(3+DILONG)=DISTEMP_DISOLD
   53: 23	. I DIVALUE'?.E1L.E Q
   54: 	. S DIREF=$NA(@DISNAMEX@(2+DILONG))
   55: 	. I @DIREF="" S DISOLD=""
   56: 	. E  S DISOLD=" X "_DIREF
   57: 	. S @DIVNAME@(4+DILONG)=$TR($P(DIVALUE,","),DILOWER,DIUPPER)
   58: 	. S @DISNAME@(4+DILONG)=$TR(DISTEMP,DILOWER,DIUPPER)_DISOLD
   59: 	
   60: LONG	I 'DILONG Q
   61: 	I DIFLAGS'["g" S DIFLAGS=DIFLAGS_"g"
   62: 	N DINODE,DISLONG,DISPART,DISXACT
   63: 	F DINODE=5:1:8 I $D(@DIVNAME@(DINODE))#2 D
   64: 	. S @DIVNAMES@(DINODE)=$E(@DIVNAME@(DINODE),1,30)
   65: 	. S DIREF=$NA(@DISNAMEX@(DINODE))
   66: 	. I @DIREF="" S DISLONG=""
   67: 	. E  S DISLONG=" X "_DIREF
   68: 	. S DIREF=$NA(@DIVNAMEX@(DINODE))
   69: 	. S DISPART="I $P(DIFIELD,"_DIREF_")="""""_DISLONG
   70: 	. S DISXACT="I $P(DIFIELD,U)="_DIREF_DISLONG
   71: L10	. I DIFLAGS["X" S @DISNAMES@(DINODE)=DISXACT Q
   72: 	. I DIFLAGS'["O" S @DISNAMES@(DINODE)=DISPART Q
   73: 	. S @DISNAMES@(DINODE)=DISXACT
   74: 	. S @DISNAMES@(DINODE,2)=DISPART
   75: 	Q
   76: 	
   77: SPECIAL(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DINDEX,DICOUNT,DIFAIL,DISCREEN,DIDENT,DIOUT,DILIST)	
   78: 	; FIND--check the pick value for special formats
   79: 	; proc, DICOUNT, DIDENT, & DIFAIL by reference
   80: 	S DIOUT=0
   81: 	I U[DIVALUE S DIFAIL=1,DIOUT=1 Q
   82: 	I DIVALUE'?.ANP S DIFAIL=1,DIOUT=1 D ERR^DICF6(204,"","","",DIVALUE) Q
   83: 11	I DIVALUE=" " D  S DIOUT=1 Q
   84: 	. N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT("Q"),1,28)))
   85: 	. N DINODEL S DINODEL=$L(DINODE,",")
   86: 	. I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT("Q"),29,9999) S DIFAIL=1 Q
   87: 	. N DIENTRY S DIENTRY=$P(DINODE,",",DINODEL)
   88: 	. I 'DIENTRY S DIFAIL=1 Q
   89: 	. S DIEN=DIENTRY_DIEN
   90: 	. D ENTRY
   91: 	. I DICOUNT'>DICOUNT(0) S DIFAIL=1 Q
   92: 12	I DIVALUE?1"`"1.N D  S DIOUT=1 Q
   93: 	. N DIENTRY S DIENTRY=$E(DIVALUE,2,$L(DIVALUE))
   94: 	. S DIEN=DIENTRY_DIEN
   95: 	. D ENTRY
   96: 	. S $P(DIEN,",")=""
   97: 	. I DICOUNT'>DICOUNT(0) S DIFAIL=1
   98: 13	I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D  Q:DICOUNT>DICOUNT(0)
   99: 	. N DI001 S DI001=$D(^DD(DIFILE,.001))
  100: 	. N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2)
  101: 	. I $D(@DIROOT@(DIVALUE)) D  I DICOUNT>DICOUNT(0) Q
  102: 	. . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIROOT@("A["))'="") Q
  103: 	. . S DIEN=DIVALUE_DIEN
  104: 	. . D ENTRY
  105: 	. . S $P(DIEN,",")=""
  106: 	. . I DIFLAGS["q" S DIOUT=1
  107: 	Q
  108: 	
  109: ENTRY	D ENTRY^DICF3(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST)
  110: 	Q