Return to DICF1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICF1.m, revision 1.1

1.1     ! snw         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