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

BGULIST2.m

Go to the documentation of this file.
BGULIST2 ; IHS/OIT/MJL - GENERAL FILE LISTER ;  [ 11/07/2007  2:26 PM ]
 ;;1.5;BGU;**3**;MAY 26, 2005
INIT ;EP Called by BGULIST
 S U="^",BGUFILE=$G(BGUFILE),BGUIEN=$G(BGUIEN),BGUMORE=$G(BGUMORE),BGUCRFS=$G(BGUCRFS),BGUARRAY=$G(BGUARRAY),BGUSTART=$G(BGUSTART,1),BGUSCR=$G(BGUSCR),BGUTDLM=$C(175) S:BGUSCR["|" BGUSCR=$TR(BGUSCR,"|","^")
 S BGUBEGIN=$G(BGUBEGIN),BGUEND=$G(BGUEND),BGUDIR=$G(BGUDIR,"F"),BGUVLST=$G(BGUVLST),BGUCNT=0,BGUICNT=0,BGUICNT1=0,BGUOFN=0,BGUSETD=0,BGUERROR=0,BGUFMCK=0,BGUERMSG="",BGUOFILE=BGUFILE
 S BGULDIR=$G(BGULDIR,BGUDIR),BGUFIRST=$G(BGUFIRST),BGULAST=$G(BGULAST,"UNDEF"),BGULLEV=0,BGUMAX=$G(BGUMAX,25),BGUCNDS=$G(BGUCNDS)
 I BGUCRFS'="",BGUBEGIN'="",$E(BGUEND,1,$L(BGUBEGIN))=BGUBEGIN S BGUFMCK=$L(BGUBEGIN)
 S:'BGUMAX BGUMAX=25 S:BGUDIR="" BGUDIR="F" S BGUDIR1=$S(BGUDIR="F":1,1:-1)
 I BGUDIR1=1,'BGUMORE,BGUIEN="" S BGUSTART=1
 S:$G(BGULFILE)'=BGUFILE BGUSTART=1,BGULVLST=""
 I $G(BGULCRFS)'=BGUCRFS,BGUIEN="",$G(BGULIEN)="" S BGUSTART=1
 I BGUSTART D  Q:BGUERROR
 .S BGUGREF="",BGUGBL=$$GETGBL(BGUFILE),BGUMGBL=BGUGBL I BGUGBL="" S BGUERROR=1,BGUERMSG="Invalid File Requested!" Q
 .I BGUCRFS'="" S BGUCRFS1=BGUCRFS,BGUCGBL=BGUGBL D:$E(BGUCRFS,1,3)="SC:" @($P($P(BGUCRFS,"SC:",2),"|")_U_$P(BGUCRFS,"|",2)) D:BGUCRFS1[";"  Q:BGUERROR  S BGUCGREF=BGUCGBL_"BGUSVSUB(1),BGUSVSUB(2),BGUSUB(1))"
 ..S BGUCGBL=$$GETGBL($P(BGUCRFS1,";")) I BGUCGBL="" S BGUERROR=1,BGUERMSG="Invalid Cross-reference specified -- "_$P(BGUCRFS1,";") Q
 ..S BGUCRFS1=$P(BGUCRFS1,";",2)
 .I '$D(DT) D NOW^%DTC S DT=X K %,%I,%H
 I BGUVLST'=$G(BGULVLST),BGUOFN=0 K BGUFGBL,BGUFLDS I BGUVLST'="" F BGUN=1:1:$L(BGUVLST,",") S BGUX=$P(BGUVLST,",",BGUN) D GETFLDS
 I BGUCNDS'=$G(BGULCNDS) D BLDCND^BGUCND S BGUN="" F  S BGUN=$O(BGUCND(BGUN)) Q:BGUN=""  S BGUXX=$P(BGUCND(BGUN),U,2),BGUX=$P(BGUXX,"~",2) D GETFLDS S BGUX=$P(BGUXX,"~",3) I BGUX?1AN.AN D GETFLDS
 S BGUOFN1=0 F  S BGUOFN1=$O(BGULNKFD(BGUOFN1)) Q:'BGUOFN1  S BGUX=BGULNKFD(BGUOFN1),BGUOFILE=$P($P(BGUX,":",1),"F",2),BGUIVS=$P(BGUX,":",2),BGUOVS=$P(BGUX,":",3) D
 .S BGUMXIV="" F BGUN1=1:1:$L(BGUIVS,"~") S BGUIV=$P(BGUIVS,"~",BGUN1) I BGUIV,BGUIV'[";",$L(BGUIV,"!")>$L(BGUMXIV,"!")!(BGUMXIV="") S BGUMXIV=BGUIV
 .S:BGUMXIV'="" BGULNKFD(BGUOFN1,0)=BGUMXIV
 .F BGUN1=1:1:$L(BGUOVS,"~") S BGUOV=BGUOFILE_";"_$P(BGUOVS,"~",BGUN1),BGUOV(BGUOV)=BGUOFN1
 S BGUOFN1=0,BGUOLEV=1,BGULFORD="" F  S:BGUOLEV=1 BGUOFN1=BGUOFN1+1,BGUOFN(BGUOLEV)=BGUOFN1,BGUTSEG="" Q:'$D(BGULNKFD(BGUOFN1))  D
 .I BGUOLEV=1,","_BGULFORD_","[(","_BGUOFN1_",") Q
 .S BGUX=BGULNKFD(BGUOFN(BGUOLEV)) S BGUOFILE=$P($P(BGUX,":",1),"F",2),BGUIVS=$P(BGUX,":",2) D
 ..S BGUINC=0 F BGUOLEV(BGUOLEV)=$G(BGUOLEV(BGUOLEV),1):1:$L(BGUIVS,"~") S BGUIV=$P(BGUIVS,"~",BGUOLEV(BGUOLEV)),BGUOVLV=$G(BGUOV(BGUIV)) I BGUOVLV D  Q:BGUINC
 ...I $D(BGULNKFD(BGUOVLV,0)),$L(BGULNKFD(BGUOVLV,0),"!")>$L($G(BGULNKFD(BGUOFN(BGUOLEV),0)),"!") S BGULNKFD(BGUOFN(BGUOLEV),0)=BGULNKFD(BGUOVLV,0)
 ...I BGUOVLV>BGUOFN(BGUOLEV),","_BGULFORD_","'[(","_BGUOVLV_",") S BGUTSEG=BGUOVLV_","_BGUTSEG,BGUOLEV=BGUOLEV+1,BGUOFN(BGUOLEV)=BGUOVLV,BGUINC=1
 ..Q:BGUINC
 ..I BGUOLEV>1 S BGUOLEV=BGUOLEV-1 Q:BGUOLEV>1
 ..S:BGULFORD'="" BGULFORD=BGULFORD_"," S:BGUTSEG'="" BGULFORD=BGULFORD_BGUTSEG_"," S BGULFORD=BGULFORD_BGUOFN1 K BGUOLEV S BGUOLEV=1
 K BGUINC,BGUOFN,BGUOLEV,BGUOV,BGUOVLV,BGUTSEG
 I BGULFORD'="" S BGUOFN=0 F BGUN=1:1:$L(BGULFORD,",") S BGUOFN1=$P(BGULFORD,",",BGUN),BGUX=BGULNKFD(BGUOFN1) D GETOFLDS
 K @BGUARRAY,BGUDLEV,BGUDNODE,BGUFDSBS,BGUFILE1,BGUFN1,BGUGLEV,BGUIV,BGUGNODE,BGULFORD,BGULFSBS,BGULNKFD,BGUMXIV,BGUOFILE(0),BGUOFN,BGUOFN1,BGUX1,BGUFRTN,BGUFRTN1
 Q
 ;
GETFLDS ;
 I BGUX[":" S BGUOFN=BGUOFN+1,BGULNKFD(BGUOFN)=BGUX Q
 D GETDDI(BGUFILE,BGUX)
 I BGUX1="",BGUX,BGUX=+BGUX S BGUSF(BGUX)=""
 Q
 ;
GETOFLDS ;
 S BGUOFILE=$P($P(BGUX,":",1),"F",2),BGUIVS=$P(BGUX,":",2),BGUOVS=$P(BGUX,":",3),BGUFRTN=$P(BGUX,":",4),BGUDNODE=$G(BGULNKFD(BGUOFN1,3))
 F BGUN1=1:1:$L(BGUIVS,"~") S (BGUIV,BGUX1)=$P(BGUIVS,"~",BGUN1),BGUFILE1=BGUFILE,BGUFN1=BGUX1 S:BGUX1[";" BGUFILE1=$P(BGUX1,";",1),BGUFN1=$P(BGUX1,";",2) I $E(BGUFN1)'="""" D
 .S (BGUXSBS,BGUGNODE)=""
 .D GETDDI(BGUFILE1,BGUFN1) I BGUDNODE="",BGUIV=$G(BGULNKFD(BGUOFN1,0)) S BGUDNODE=$G(BGUXSBS) S:BGUDNODE="" BGUDNODE=$G(BGUGNODE) I BGUDNODE'="" S:$E(BGUDNODE,$L(BGUDNODE))="," BGUDNODE=$E(BGUDNODE,1,$L(BGUDNODE)-1) S BGULFSBS(BGUIV)=BGUDNODE
 D
 .I BGUDNODE="",$D(BGULNKFD(BGUOFN1,0)) S BGUDNODE=$G(BGULFSBS(BGULNKFD(BGUOFN1,0)))
 .S:BGUDNODE="" BGUDNODE=0 S BGUDLEV=$L(BGUDNODE,",")*2 S:'$D(BGULNKFD(BGUOFN1,3)) BGULNKFD(BGUOFN1,3)=BGUDNODE
 .I '$D(BGUOFILE(0,BGUOFILE_U_BGUIVS)) S BGUOFN=BGUOFN+1,BGUOFILE(0,BGUOFILE_U_BGUIVS)=BGUDLEV_U_BGUDNODE_U_BGUOFN,@("BGUOFILE(BGUDLEV,"_BGUDNODE_",BGUOFN)")=BGUOFILE_U_BGUIVS_U_BGUOVS_U_BGUFRTN Q
 .S BGUOFILX=BGUOFILE(0,BGUOFILE_U_BGUIVS)
 .S BGUXAR="BGUOFILE($P(BGUOFILX,U),"_$P(BGUOFILX,U,2)_",$P(BGUOFILX,U,3))"
 .S BGUOFLX=@BGUXAR,BGUFRTN1=$P(BGUOFLX,U,4)
 .S BGUFRTNS="" S:BGUFRTN1'="" BGUFRTNS=BGUFRTN1 I BGUFRTN'="" S:BGUFRTNS'="" BGUFRTNS=BGUFRTNS_ " " S BGUFRTNS=BGUFRTNS_BGUFRTN
 .;S $P(@BGUXAR,U,3,4)=$P(BGUOFLX,U,3)_"~"_BGUOVS_U_$S(BGUFRTN1="":BGUFRTN,BGUFRTN="":BGUFRTN1,1:BGUFRTN1_","_BGUFRTN) K BGUOFILX,BGUOFLX
 .S @BGUXAR=$P(@BGUXAR,U,1,2)_U_$P(BGUOFLX,U,3)_"~"_BGUOVS_U_BGUFRTNS K BGUFRTNS,BGUOFILX,BGUOFLX
 F BGUN1=1:1:$L(BGUOVS,"~") S BGUOV=$P(BGUOVS,"~",BGUN1) D GETDDI(BGUOFILE,BGUOV) I BGUX1="",BGUOV,BGUOV=+BGUOV S BGUSF(BGUOV)=""
 Q
 ;
 ; Restore all the variables previously saved during the previous run
 ; for a particular client's object
RESTORE ;EP Called by BGULIST
 S BGUTV="" F  S BGUTV=$O(^TMP("BGUSAVE",BGUID,BGUTV)) Q:BGUTV=""  M @BGUTV=^TMP("BGUSAVE",BGUID,BGUTV)
 S BGULVLST="",BGUN="" F  S BGUN=$O(^TMP("BGULVLST",BGUID,BGUN)) Q:BGUN=""  S BGULVLST=BGULVLST_^TMP("BGULVLST",BGUID,BGUN)
 K ^TMP("BGUSAVE",BGUID),^TMP("BGULVLST",BGUID)
 Q
 ;
 ; Save all of the variables required to preserve state
SAVE ;EP Called by BGULIST
 S BGUTVS="BGUCGREF,BGUCHNG,BGUCND,BGUCMXL,BGUFGBL,BGUFLDS,BGUGBL,BGUGREF,BGUL,BGULAST,BGULCRFS,BGULCNDS,BGULDIR,BGULEV,BGULFILE,BGULFRST,BGULICNT,BGULIEN,BGULLAST,BGULLEV,BGULSIEN,BGUMGBL,BGUOFILE,BGUSF,BGUSTART,BGUSTLEV,BGUSUB,DT"
 F BGUN=1:1:$L(BGUTVS,",") S BGUTV=$P(BGUTVS,",",BGUN) M:$D(@BGUTV) ^TMP("BGUSAVE",BGUID,BGUTV)=@BGUTV
 F BGUN=1:1:$L(BGULVLST)\400+($L(BGULVLST)#400>0) S ^TMP("BGULVLST",BGUID,BGUN)=$E(BGULVLST,BGUN-1*400+1,BGUN*400)
 K BGUTV,BGUTVS
 Q
 ;
 ; Input: FileMan name     Returns: Global reference
 ;        or number
GETGBL(BGUX) ;
 S:'BGUX BGUX=$O(^DIC("B",BGUX,"")) Q:BGUX="" BGUX
 S BGUX=$G(^DIC(BGUX,0,"GL"))
 Q BGUX
 S BGUDCK=$D(@BGUGREF),BGUY=$G(^(BGUSUB(BGULEV))) Q BGUY
 Q BGUY
 ;
SETDATA(BGUX,BGUXN,BGUXN1) ;
 S ^TMP("BGULIST",BGUID,BGUXN,BGUXN1)=BGUX
 Q
 ;
 ; Get the definition of a field from ^DD for a FileMan file
 ; BGULKUA - Pointer lookups are allowed
 ; BGULKU - flag indicating that if a field is a pointer type
 ;          do the lookup -- replace the pointer value with the looked
 ;          up value
 ; If a field has a -P arguement that indicates that the pointer is to
 ; be used (the IEN) -- the lookup should not take place.
GETDDI(BGUXFID,BGUXFN) ;
 S BGUGLEV=$L(BGUXFN,"!")*2,BGUGNODE=0,BGULKU=1 I BGUXFN["-" S:BGUXFN["-P" BGULKU=0 S BGUXFN=$P(BGUXFN,"-")
 I BGUXFN="*" D  Q
 .S BGUXFN=0 F  S BGUXFN=$O(^DD(BGUFILE,BGUXFN)) Q:'BGUXFN  D GCMPDDI(BGUXFID,BGUXFN)
 .K BGUXCFN,BGUXFLEV,BGUXSFID
 I BGUXFN'["!" S BGUX1=$G(^DD(BGUXFID,BGUXFN,0)) Q:BGUX1=""  D  Q
 .S BGUGLEV=$L(BGUXFN,"!")*2,BGUGNODE=$P(BGUX1,U,4),BGUXN=$P(BGUGNODE,";",2),BGUGNODE=$P(BGUGNODE,";")
 .I $P(BGUX1,U,2)'["C" D  Q
 ..S:'$D(BGUFLDS(BGUXFID,BGUGNODE,"FN",BGUXN,BGUXFN)) BGUFGBL(BGUXFID,BGUGNODE)="",BGUFLDS(BGUXFID,BGUGNODE,"FN",BGUXN,BGUXFN)=$S('BGULKU:"",$P(BGUX1,U,2)["P"!($P(BGUX1,U,2)["V"):$$PTRDEF(BGUX1),1:"") Q
 .D CFDEF(BGUXFN)
 S BGUXFID1=BGUXFID,BGUXSBS=""
 F BGUN2=1:1:$L(BGUXFN,"!") S BGUXFN1=$P(BGUXFN,"!",BGUN2),BGUX1=$G(^DD(BGUXFID1,BGUXFN1,0)) Q:BGUX1=""  S BGUGNODE=$P($P(BGUX1,U,4),";") S:BGUGNODE'=" " BGUXSBS=BGUXSBS_""""_BGUGNODE_""",",BGUXFID1=+$P(BGUX1,U,2)
 D:BGUX1'=""
 .I $P(BGUX1,U,2)["C" D CFDEF(BGUXFN,BGUXSBS) Q
 .S BGUXN=$P($P(BGUX1,U,4),";",2)
 .I '$D(@("BGUFLDS("_BGUXFID_","_BGUXSBS_"""FN"",BGUXN,BGUXFN)")) D
 ..S @("BGUFLDS("_BGUXFID_","_BGUXSBS_"""FN"",BGUXN,BGUXFN)")=$S('BGULKU:"",$P(BGUX1,U,2)["P"!($P(BGUX1,U,2)["V"):$$PTRDEF(BGUX1),1:"")
 ..S @("BGUFGBL(BGUXFID,"_$E(BGUXSBS,1,$L(BGUXSBS)-1)_")")=""
 I BGUX1="",BGUN2=1,'$D(BGUFLDS(0,BGUXFID,BGUXFN)) D
 .S BGUX1=$G(^DD(BGUXFID,.01,0)) Q:BGUX1=""
 .S BGUGNODE=$P(BGUX1,U,4),BGUXN=$P(BGUGNODE,";",2),BGUGNODE=$P(BGUGNODE,";"),BGUXSBS=$P(BGUIVS,"~")_","""_BGUGNODE_""""
 .I '$D(@("BGUFLDS("_BGUXFID_","_BGUXSBS_",""FN"",BGUXN,BGUXFN)")) D
 ..S @("BGUFLDS("_BGUXFID_","_BGUXSBS_",""FN"",BGUXN,BGUXFN)")=$S('BGULKU:"",$P(BGUX1,U,2)["P"!($P(BGUX1,U,2)["V"):$P($$GETGBL(BGUXFID),U,2)_"\"_$$PTRDEF(BGUX1),1:"")
 ..S @("BGUFGBL(BGUXFID,"_BGUXSBS_")")="",BGUFLDS(0,BGUXFID,BGUXFN)=""
 K BGULKU,BGUN2,BGUXFID1
 Q
 ;
 ; Gets the definitions for all of the fields defined for a global
 ;
GCMPDDI(BGUXFID,BGUXFN) ;
 S BGUXFLEV=1,BGUXFID(1)=BGUXFID,BGUXFN(1)=BGUXFN
 F  D  Q:BGUXFLEV=1
 .I BGUXFLEV>1 S BGUXFN(BGUXFLEV)=$O(^DD(BGUXFID(BGUXFLEV),$G(BGUXFN(BGUXFLEV),0))) I 'BGUXFN(BGUXFLEV) K BGUXFN(BGUXFLEV) S BGUXFLEV=BGUXFLEV-1 Q
 .S BGUX1=$G(^DD(BGUXFID(BGUXFLEV),BGUXFN(BGUXFLEV),0)) Q:BGUX1=""
 .S BGUXSBS(BGUXFLEV)=$P($P(BGUX1,U,4),";")
 .S BGUXSFID=+$P(BGUX1,U,2) S:BGUXSFID BGUXFLEV=BGUXFLEV+1,BGUXFID(BGUXFLEV)=BGUXSFID
 .I 'BGUXSFID S BGUXN=$P($P(BGUX1,U,4),";",2) D
 ..S BGUXSBS="",BGUXCFN=""
 ..F BGUN2=1:1:BGUXFLEV D
 ...I BGUXSBS(BGUN2)'=" " S:BGUN2>1 BGUXSBS=BGUXSBS_"," S BGUXSBS=BGUXSBS_""""_BGUXSBS(BGUN2)_""""
 ...S:BGUN2>1 BGUXCFN=BGUXCFN_"!" S BGUXCFN=BGUXCFN_BGUXFN(BGUN2)
 ..I BGUXSBS(BGUXFLEV)'=" " S @("BGUFGBL(BGUXFID,"_BGUXSBS_")")="",@("BGUFLDS("_BGUXFID_","_BGUXSBS_",""FN"",BGUXN,BGUXCFN)")=$S($P(BGUX1,U,2)["P"!($P(BGUX1,U,2)["V"):$$PTRDEF(BGUX1),1:"") Q
 ..D:$P(BGUX1,U,2)["C" CFDEF(BGUXCFN,BGUXSBS)
 Q
 ;
 ; Looks up the file lookup definition for a pointer field.  Accumulates
 ; lookup info until field pointed to is not a pointer.
PTRDEF(BGUX) ;
 Q:$P(BGUX,U,2)["V" "V"
 S BGUY=""
 F BGUPTRC=1:1 S:BGUPTRC>1 BGUY=BGUY_"\" S BGUY=BGUY_$P(BGUX,U,3),BGUX=+$P($P(BGUX,U,2),"P",2),BGUX=$G(^DD(BGUX,.01,0)) Q:$P(BGUX,U,2)'["P"
 K BGUPTRC
 Q BGUY
 ;
CFDEF(BGUX,BGUY) ;
 S BGUGNODE=$G(^DD(BGUXFID,$P(BGUX,"!",$L(BGUX,"!")),9.01)) S:BGUGNODE="" BGUGNODE=0 S:BGUGNODE BGUGNODE=$P(BGUGNODE,";",$L(BGUGNODE,";")),BGUGNODE=$P($P(^DD($P(BGUGNODE,U),$P(BGUGNODE,U,2),0),U,4),";")
 S BGUXSBS=$G(BGUY)
 I BGUXSBS'="" S:$E(BGUXSBS,$L(BGUXSBS))'="," BGUXSBS=BGUXSBS_","
 S BGUXSBS=BGUXSBS_BGUGNODE
 S BGUXN=$P(BGUX1,U,5,999),@("BGUFGBL(BGUXFID,"_BGUXSBS_")")="",@("BGUFLDS("_BGUXFID_","_BGUXSBS_",""CF"",BGUX)")=BGUXN
 Q
GETCFET ;
 Q
 ;
GETPTR(BGUX) ;
 S BGUV(BGUXFID,BGUFN,"SUB")=BGUX,BGUV(BGUXFID,BGUFN_"-P")=BGUX
 Q:BGUPTR="V" $P($G(@("^"_$P(BGUX,";",2)_""""_$P(BGUX,";")_""",0)")),U,1)
 S BGUYY=BGUX
 F BGUIDX=1:1:$L(BGUPTR,"\") S BGUYY=$P($G(@("^"_$P(BGUPTR,"\",BGUIDX)_""""_BGUYY_""",0)")),U,1)
 S:BGUYY="" BGUYY=BGUX
 K BGUIDX
 Q BGUYY
 ;
BEGIN(BGUX) ;
 I BGUX="" Q ""
 I BGUX=0 Q ""
 I BGUX,BGUX=+BGUX Q BGUX-1
 Q $E(BGUX,1,$L(BGUX)-1)_$C($A($E(BGUX,$L(BGUX)))-1)_"~"
 ;
END(BGUX) ;
 D
 .I BGUEND="" S BGUY=BGUX="" Q
 .I BGUX,BGUEND,BGUX=+BGUX,BGUEND=+BGUEND S BGUY=BGUX>BGUEND Q
 .S BGUY=BGUX]]BGUEND
 Q BGUY
 ;
FIRSTSET ;
 S BGUDAT=BGUTDLM_BGUSUB(1)_$C(20)_BGUDAT,BGUV(BGUFILE,.001)=BGUSUB(1),BGUDSET=BGUDSET+1 S:BGUCRFS'="" BGUV(BGUFILE,.0001)=BGUSVSUB(2)
 Q
 ;
COUNT ;
 S BGUICNT=BGUICNT+1,BGUICNT1=BGUICNT,BGUCNT=0 S:BGUDIR1<0 BGUICNT1=BGUMAX+1-BGUICNT1
 Q
 ;
SFLDS ;
 S BGUX="" F  S BGUX=$O(BGUSF(BGUX)) Q:BGUX=""  S BGUCNT=BGUCNT+1 D SETDATA("SF:"_BGUX_$C(25)_BGUV(BGUFILE,BGUX),BGUICNT1,BGUCNT)
 Q
 ;
SCRN ;
 X "S BGUSCRV="_BGUSCR I BGUSCRV K BGUSCRV Q
 D RMV
 Q
 ;
RMV ;
 K ^TMP("BGULIST",BGUID,BGUICNT1),BGUSCRV
 S BGUICNT=BGUICNT-1,BGUDSET=BGUDSET-1
 Q
RMV1 ;
 K ^TMP("BGULIST",BGUID,BGUICNT1,BGUCNT)
 S BGUCNT=BGUCNT-1 I BGUCNT<1 S BGUCNT=0
 Q