Return to DICF1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICF1.m, revision 1.1.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