©2011-2018 Open Source Electronic Health Record Alliance
This work is licensed under a Creative Commons Attribution 3.0 Unported License
This work is licensed under a Creative Commons Attribution 3.0 Unported License
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