freem_fileman/USER/DICF1.m - view

File: [Coherent Logic Development] / freem_fileman / USER / DICF1.m
Revision 1.1: download - view: text, annotated - select for diffs
Mon Apr 28 14:13:19 2025 UTC (5 weeks, 5 days ago) by snw
Branches: MAIN
CVS tags: HEAD

Restructure repository

DICF1 ;SEA/TOAD-VA FileMan: Finder, Part 2 (Transform) ;11/17/94 12:21 ; ;;21.0;VA FileMan;;Dec 28, 1994 ;Per VHA Directive 10-93-142, this routine should not be modified. XFORM(DIFLAGS,DIVALUE,DISCREEN,DILVA,DILIST) ; FIND--produce array of values and screens by transforming input ; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference BASIC N DISNAME S DISNAME="DILVA(""S"")" N DIVNAME S DIVNAME="DILVA(""V"")" S @DIVNAME=DIVALUE S @DISNAME=DISCREEN SETLONG N DILONG S DILONG=$S(DIFLAGS["Q":0,1:$L(DIVALUE)>29&(DIFLAGS'["U")*4) I DILONG N DISNAMES S DISNAMES=DISNAME,DISNAME=$NA(@DISNAME@(0)) N DISNAMEX S DISNAMEX=$NA(@DILIST("LVA")@("S")) I DILONG S DISNAMEX=$NA(@DISNAMEX@(0)) I DILONG N DIVNAMES S DIVNAMES=DIVNAME,DIVNAME=$NA(@DIVNAME@(0)) N DIVNAMEX S DIVNAMEX=$NA(@DILIST("LVA")@("V")) I DILONG S DIVNAMEX=$NA(@DIVNAMEX@(0)) S @DIVNAME@(1+DILONG)=DIVALUE S @DISNAME@(1+DILONG)=DISCREEN I DIFLAGS["Q" Q LOWER I DIVALUE?.E1L.E N DILOWER,DIUPPER D . S DILOWER="abcdefghijklmnopqrstuvwxyz" . S DIUPPER="ABCDEFGHIJKLMNOPQRSTUVWXYZ" . N DITEMP S DITEMP=$TR(DIVALUE,DILOWER,DIUPPER) . S @DIVNAME@(2+DILONG)=DITEMP . S @DISNAME@(2+DILONG)=DISCREEN COMMA N DIREF I DIVALUE[",",DIFLAGS'["X" D . S DIFLAGS=DIFLAGS_"g" . N DISTEMP S DISTEMP="" . N DIPART1 S DIPART1=" I %?.E1P1""" . N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1""" . N DIPART3 S DIPART3=""".E))" . N DIOUT S DIOUT=0 21 . N DIPIECE,DIVPIECE F DIPIECE=2:1 D I DIOUT Q . . S DIVPIECE=$P(DIVALUE,",",DIPIECE) . . I DIVPIECE["""" Q . . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE)) . . I DIVPIECE="" S DIOUT=1 Q . . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q . . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3 22 . I DISTEMP="" Q . S DISTEMP="S %=DIFIELD"_DISTEMP . S DIREF=$NA(@DISNAMEX@(1+DILONG)) . N DISOLD I @DIREF="" S DISOLD="" . E S DISOLD=" X "_DIREF . S @DIVNAME@(3+DILONG)=$P(DIVALUE,",") . S @DISNAME@(3+DILONG)=DISTEMP_DISOLD 23 . I DIVALUE'?.E1L.E Q . S DIREF=$NA(@DISNAMEX@(2+DILONG)) . I @DIREF="" S DISOLD="" . E S DISOLD=" X "_DIREF . S @DIVNAME@(4+DILONG)=$TR($P(DIVALUE,","),DILOWER,DIUPPER) . S @DISNAME@(4+DILONG)=$TR(DISTEMP,DILOWER,DIUPPER)_DISOLD LONG I 'DILONG Q I DIFLAGS'["g" S DIFLAGS=DIFLAGS_"g" N DINODE,DISLONG,DISPART,DISXACT F DINODE=5:1:8 I $D(@DIVNAME@(DINODE))#2 D . S @DIVNAMES@(DINODE)=$E(@DIVNAME@(DINODE),1,30) . S DIREF=$NA(@DISNAMEX@(DINODE)) . I @DIREF="" S DISLONG="" . E S DISLONG=" X "_DIREF . S DIREF=$NA(@DIVNAMEX@(DINODE)) . S DISPART="I $P(DIFIELD,"_DIREF_")="""""_DISLONG . S DISXACT="I $P(DIFIELD,U)="_DIREF_DISLONG L10 . I DIFLAGS["X" S @DISNAMES@(DINODE)=DISXACT Q . I DIFLAGS'["O" S @DISNAMES@(DINODE)=DISPART Q . S @DISNAMES@(DINODE)=DISXACT . S @DISNAMES@(DINODE,2)=DISPART Q SPECIAL(DIFILE,DIEN,DIFLAGS,DIROOT,DIVALUE,DINDEX,DICOUNT,DIFAIL,DISCREEN,DIDENT,DIOUT,DILIST) ; FIND--check the pick value for special formats ; proc, DICOUNT, DIDENT, & DIFAIL by reference S DIOUT=0 I U[DIVALUE S DIFAIL=1,DIOUT=1 Q I DIVALUE'?.ANP S DIFAIL=1,DIOUT=1 D ERR^DICF6(204,"","","",DIVALUE) Q 11 I DIVALUE=" " D S DIOUT=1 Q . N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT("Q"),1,28))) . N DINODEL S DINODEL=$L(DINODE,",") . I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT("Q"),29,9999) S DIFAIL=1 Q . N DIENTRY S DIENTRY=$P(DINODE,",",DINODEL) . I 'DIENTRY S DIFAIL=1 Q . S DIEN=DIENTRY_DIEN . D ENTRY . I DICOUNT'>DICOUNT(0) S DIFAIL=1 Q 12 I DIVALUE?1"`"1.N D S DIOUT=1 Q . N DIENTRY S DIENTRY=$E(DIVALUE,2,$L(DIVALUE)) . S DIEN=DIENTRY_DIEN . D ENTRY . S $P(DIEN,",")="" . I DICOUNT'>DICOUNT(0) S DIFAIL=1 13 I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D Q:DICOUNT>DICOUNT(0) . N DI001 S DI001=$D(^DD(DIFILE,.001)) . N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2) . I $D(@DIROOT@(DIVALUE)) D I DICOUNT>DICOUNT(0) Q . . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIROOT@("A["))'="") Q . . S DIEN=DIVALUE_DIEN . . D ENTRY . . S $P(DIEN,",")="" . . I DIFLAGS["q" S DIOUT=1 Q ENTRY D ENTRY^DICF3(DIFILE,.DIEN,.DIFLAGS,.DIROOT,.DIVALUE,DINDEX,.DICOUNT,.DISCREEN,.DIDENT,.DILIST) Q