BARLNK ; IHS/SD/LSL - LINK FILES ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;;
EN ; EP
SELECT ;
; Select links, hits, sorts, prints
; Select a file
D HOME^%ZIS
K DIC
S DIC=$$DIC^XBDIQ1(90055.5)
S DIC(0)="AEQML"
D ^DIC
Q:Y'>0
S BARFN=+Y
S $P(^BARDD(90055.5,BARFN,1,0),U,2)="90055.51A"
K DIR
;
PICK ; EP
; SELECT
S DIR(0)="SO^J:Join;S:Sorts;P:Prints;W:Walk;E:Edit Items;L:List Items"
S BARTYP("J")="Join(s)"
S BARTYP("H")="Pick(s)"
S BARTYP("S")="Sort(s)"
S BARTYP("P")="Print(s)"
D ^DIR
I (Y="")!(Y="^") G SELECT
D @Y
G PICK
; *********************************************************************
;
L ; EP
I '$D(^BARRGIT(BARFN)) W !,"NOT BUILT YET !",! H 2 Q
D LIST^BARLNRPT(BARFN)
Q
; *********************************************************************
;
PICKQ ;
Q
; *********************************************************************
;
DDPULL(BARFN) ;
; build array of pointers from DD using truth test in BART
K BARDD
S BARDD=BARFN
D PULLDD
Q
; *********************************************************************
;
PULLDD ; EP
; PULL DD
K ^TMP("BARDD",$J)
S BARFD=.001
S BARFDC=0
F S BARFD=$O(^DD(BARFN,BARFD)) Q:BARFD'>0 X BART I $T D
. I BARTYP="J" S X=$P(@X,U,2)
. S BARFDC=BARFDC+1
. S ^TMP("BARDD",$J,BARFDC)=BARFD_"^"_+X
. S ^TMP("BARDD",$J,"B",BARFD)=BARFDC
Q
; *********************************************************************
;
E ; EP
; Edit Items
S XBSRCFL=+BARFN
K DIC,DR,DA
S DIC=$$DIC^XBDIQ1(90056.3)
S DIC(0)="AEQML"
D ^DIC
I Y'>0 Q
K ITM
S ITMDA=+Y
D DSPITM
S DIE=DIC
S DA=ITMDA
S DR=".01;.04;.05;1.04"
D ^DIE
D DSPITM
G E
; *********************************************************************
;
DSPITM ; EP
D ENP^XBDIQ1(90056.3,ITMDA,".01:1.04","ITM(")
W !,"Field |File",?15,ITM(.01)
W !,"Attribute",?15,ITM(.04)
W !,"FM Path",?15,ITM(.05)
W !,"Data Path",?15,ITM(1.04)
W !
Q
; *********************************************************************
;
JDDSP ;
; display BARDD for joins field and file pointer
D DDPULL(BARFN)
W @IOF
S X=$P(^DIC(BARDD,0),U)_" FILE Fields"
W !,?10,X
S BARFC=$O(^TMP("BARDD",$J,"A"),-1)
S BARFCH=(BARFC\2)+(BARFC#2)
F I=1:1:BARFCH D
. S BARFD=$P(^TMP("BARDD",$J,I),U)
. S BARFN0=$P(^TMP("BARDD",$J,I),U,2)
. W !,$J(I,3),?5,$E($P(^DD(BARDD,BARFD,0),U),1,16)
. W ?23,$E($P(^DIC(BARFN0,0),U),1,16)
. S J=I+BARFCH
. Q:'$D(^TMP("BARDD",$J,J))
. S BARFD=$P(^TMP("BARDD",$J,J),U)
. S BARFN0=$P(^TMP("BARDD",$J,J),U,2)
. W ?40,$J(J,3),?45,$E($P(^DD(BARDD,BARFD,0),U),1,16)
. W ?63,$E($P(^DIC(BARFN0,0),U),1,16)
Q
; *********************************************************************
;
GDDSP ;
; display BARDD general 3 columns
D DDPULL(BARFN)
W @IOF
S X=$P(^DIC(BARDD,0),U)_" FILE Fields"
W !,?10,X
S BARFC=$O(^TMP("BARDD",$J,"A"),-1)
S BARFCH=BARFC\3
S:(BARFC#3) BARFCH=BARFCH+1
F I=1:1:BARFCH D
. S BARFD=$P(^TMP("BARDD",$J,I),U)
. W !,$J(I,3),?5,$E($P(^DD(BARDD,BARFD,0),U),1,16)
. S J=I+BARFCH
. Q:'$D(^TMP("BARDD",$J,J))
. S BARFD=$P(^TMP("BARDD",$J,J),U)
. W ?26,$J(J,3),?31,$E($P(^DD(BARDD,BARFD,0),U),1,16)
. S J=2*BARFCH+I
. Q:'$D(^TMP("BARDD",$J,J))
. S BARFD=$P(^TMP("BARDD",$J,J),U)
. W ?55,$J(J,3),?60,$E($P(^DD(BARDD,BARFD,0),U),1,16)
Q
; *********************************************************************
;
LDDDSP ;
; display fields already tagged in with BARTYP in the link file
D DDPULL(BARFN)
K BAR,BARLNK,BARLDD
S BARDD=BARFN
S BARLDD=BARDD
I '$D(^BARDD(90055.5,BARLDD)) Q
K DIC
S DIC=$$DIC^XBDIQ1(90055.51)
S DIC("S")="I $P(^(0),U,3)[BARTYP"
K ^TMP("BARLN",$J)
D ENPM^XBDIQ1(.DIC,"BARDD,0",".01:99","^TMP(""BARLN"",$J,","I")
S BARFD=0
F BARFDC=1:1 S BARFD=$O(^TMP("BARLN",$J,BARFD)) Q:BARFD'>0 S BARLDD(BARFDC)=BARFD_"^"_^TMP("BARLN",$J,BARFD,.02,"I"),BARLDD("B",BARFD)=BARFDC
S X=$P(^DIC(BARDD,0),U)_" FILE "_BARTYP(BARTYP)
W ?10,X,!
S BARFC=$O(BARLDD("A"),-1)
S BARFCH=(BARFC\3)
S:(BARFC#3) BARFCH=BARFCH+1
F I=1:1:BARFCH D
. S BARFD=$P(BARLDD(I),U),BARFN0=$P(BARLDD(I),U,2)
. W !,$J(^TMP("BARDD",$J,"B",BARFD),3),?5,$E($P(^DD(BARLDD,BARFD,0),U),1,16)
. S J=I+BARFCH
. Q:'$D(BARLDD(J))
. S BARFD=$P(BARLDD(J),U)
. S BARFN0=$P(BARLDD(J),U,2)
. W ?26,$J(^TMP("BARDD",$J,"B",BARFD),3),?31,$E($P(^DD(BARLDD,BARFD,0),U),1,16)
. S J=I+(2*BARFCH)
. Q:'$D(BARLDD(J))
. S BARFD=$P(BARLDD(J),U)
. S BARFN0=$P(BARLDD(J),U,2)
. W ?55,$J(^TMP("BARDD",$J,"B",BARFD),3),?60,$E($P(^DD(BARLDD,BARFD,0),U),1,16)
W !
Q
; *********************************************************************
;
ADD ;
; add pointer to link file entry
; for back pointers
K DIC
I '$D(^BARDD(90055.5,BARDD)) D
. W !,"file not in join file"
. K DIR
. S DIR(0)="Y"
. S DIR("B")="Y"
. S DIR("A")="ADD File to link file "
. D ^DIR
. K DIR
. Q:'Y
. S DIC=90055.5
. S X=$P(^DIC(BARDD,0),U)
. S DIC(0)="XL"
. D ^DIC
I '$D(^BARDD(90055.5,BARDD)) W !,"FILE NOT AVAILABLE",! H 3 Q
S $P(^BARDD(90055.5,BARDD,1,0),U,2)="90055.51A" ;add header
S BARFC=$O(^TMP("BARDD",$J,"A"),-1)
W !
K DIR
S DIR(0)="LO^1:"_BARFC
S DIR("A")="Add field(s) to File "_BARTYP(BARTYP)_" entries: "
D ^DIR
K DIR
S BARY=Y
Q:(+Y'>0)
S DIC=$$DIC^XBDIQ1(90055.51)
S DIC("P")=$P(^DD(90055.5,1,0),"^",2)
S DA(1)=BARDD
S DIC(0)="XL"
F BARI=1:1 S BARFDC=$P(BARY,",",BARI) Q:'BARFDC D
. S X=$P(^TMP("BARDD",$J,BARFDC),U)
. D ^DIC
. S DA=+Y
. S DA(1)=BARDD
. S BARX=$$VAL^XBDIQ1(90055.51,.DA,.03)
. I BARX[BARTYP Q
. K DR
. I BARTYP="J" S BARFP=$P(^TMP("BARDD",$J,BARFDC),U,2) D
.. S X="`"_BARFP
.. S DIC=$$DIC^XBDIQ1(90055.5)
.. S DIC(0)="NXL"
.. N DR
.. D ^DIC
. S DIE=$$DIC^XBDIQ1(90055.51)
. S DR=".03////"_BARX_BARTYP
. I BARTYP="J" S DR=DR_";.02////^S X=BARFP"
. D ^DIE
;
ADDQ ;
Q
; *********************************************************************
;
DELL ;del entries from link file
Q
K BAR,BARLNK,BARLDD
S BARLDD=BARDD
I '$D(^BARDD(90055.5,BARLDD)) Q
K DIC
S DIC=$$DIC^XBDIQ1(90055.51)
S DIC("S")="I $P(^(0),U,3)[BARTYP"
D ENPM^XBDIQ1(.DIC,"BARDD,0",".01:99","^TMP(""BARLNK"",$J,","I")
S BARFD=0
F BARFDC=1:1 S BARFD=$O(^TMP("BARLNK",$J,BARFD)) Q:BARFD'>0 S BARLDD(BARFDC)=BARFD_"^"_^TMP("BARLNK",$J,BARFD,.02,"I")
S X=$P(^DIC(BARDD,0),U)_" FILE "_BARTYP(BARTYP)
W !!,?10,X,!
S BARFC=$O(BARLDD("A"),-1)
S BARFCH=(BARFC\3)
S:(BARFC#3) BARFCH=BARFCH+1
F I=1:1:BARFCH D
. S J=I
. S BARFD=$P(BARLDD(I),U)
. S BARFN0=$P(BARLDD(I),U,2)
. W !,$J(J,3),?5,$E($P(^DD(BARLDD,BARFD,0),U),1,16)
. S J=I+BARFCH
. Q:'$D(BARLDD(J))
. S BARFD=$P(BARLDD(J),U)
. S BARFN0=$P(BARLDD(J),U,2)
. W ?26,$J(J,3),?31,$E($P(^DD(BARLDD,BARFD,0),U),1,16)
. S J=I+(2*BARFCH)
. Q:'$D(BARLDD(J))
. S BARFD=$P(BARLDD(J),U)
. S BARFN0=$P(BARLDD(J),U,2)
. W ?55,$J(J,3),?60,$E($P(^DD(BARLDD,BARFD,0),U),1,16)
S BARFC=$O(BARLDD("A"),-1)
Q
; *********************************************************************
;
QDELL ;EP - DELL ENTRIES
; for back pointers ;I BARTYP="B" D DELL^BARLNKB Q
K DIR
S DIR(0)="LO^1:"_BARFC
S DIR("A")="Delete File "_BARTYP(BARTYP)_" Entries: "
D ^DIR
K DIR
Q:+Y'>0
S BARY=Y
S DIE=$$DIC^XBDIQ1(90055.51)
S DA(1)=BARLDD
F BARI=1:1 S BARX=$P(BARY,",",BARI) Q:BARX'>0 S BARFD=+^TMP("BARDD",$J,BARX) I $D(BARLDD("B",BARFD)) S DA=BARFD D
. S BARE=$$VAL^XBDIQ1(DIE,.DA,.03)
. S BARE=$TR(BARE,BARTYP,"")
. S:BARE="" BARE="-"
. S DR=".03////^S X=BARE"
. D ^DIE
Q
; *********************************************************************
;
B ;EP - Back pointers
S BARTYP="B"
S XBROU="DISPLAY^BARLNKB"
D EN^BARLN0
Q
; *********************************************************************
;
J ;JOINS
JOIN ;;S X=$P(^(BARFD,0),U,3) I ($P(^(0),U)'["*"),X]"",X'[":" S X="^"_X_"0)" I $D(@X)
;logic to select valid pointer fields only
S BARTYP="J"
S BART=$P($T(JOIN^BARLNK),";;",2)
S XBROU="JLM^BARLNK"
D EN^BARLN0
Q
; *********************************************************************
;
JLM ;sequence to generate Join list
D LDDDSP,JDDSP
Q
; *********************************************************************
;
HSPLM ;sequence to generate hits,sorts,prints list
D LDDDSP,GDDSP
Q
; *********************************************************************
;
H ;HITS (pointers and sets of codes) for selection
HITS ;;S X=$P(^(BARFD,0),U,3) I X]"",($P(^(0),U)'["*")
S BARTYP="H"
S BART=$P($T(HITS^BARLNK),";;",2)
S XBROU="HSPLM^BARLNK"
D EN^BARLN0
Q
; *********************************************************************
;
S ;SORTS (almost all fields , not multiples)
SORTS ;;S X=$P(^(BARFD,0),U,2) I (BARFD=.01)!((X'["A")&(X'["K")&(X'["M")&(X'["W")&(X'=+X)&(X'["F")&($P(^(0),U)'["*"))
S BARTYP="S"
S BART=$P($T(SORTS^BARLNK),";;",2)
S XBROU="HSPLM^BARLNK"
D EN^BARLN0
Q
; *********************************************************************
;
P ;PRINTS (almost all fields .. not multiples at this time)
S BARTYP="P"
S BART="S X=$P(^(BARFD,0),U) I ($P(^(0),U)'[""*"")"
S XBROU="HSPLM^BARLNK"
D EN^BARLN0
Q
; *********************************************************************
;
W ;Walk from this file and build item entries
TOP ;
S BARTGDA1=BARFN,BARLEV=1
S XBSRCFL=BARFN
S BARPATH="",BARFLPTH=""
D WALK
Q
; *********************************************************************
;
WALK ;Given BARFN add the fields and then walk the join multiples
D ^BARLNKW
Q
LMFUN ;
BARLNK ; IHS/SD/LSL - LINK FILES ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;;
EN ; EP
SELECT ;
+1 ; Select links, hits, sorts, prints
+2 ; Select a file
+3 DO HOME^%ZIS
+4 KILL DIC
+5 SET DIC=$$DIC^XBDIQ1(90055.5)
+6 SET DIC(0)="AEQML"
+7 DO ^DIC
+8 IF Y'>0
QUIT
+9 SET BARFN=+Y
+10 SET $PIECE(^BARDD(90055.5,BARFN,1,0),U,2)="90055.51A"
+11 KILL DIR
+12 ;
PICK ; EP
+1 ; SELECT
+2 SET DIR(0)="SO^J:Join;S:Sorts;P:Prints;W:Walk;E:Edit Items;L:List Items"
+3 SET BARTYP("J")="Join(s)"
+4 SET BARTYP("H")="Pick(s)"
+5 SET BARTYP("S")="Sort(s)"
+6 SET BARTYP("P")="Print(s)"
+7 DO ^DIR
+8 IF (Y="")!(Y="^")
GOTO SELECT
+9 DO @Y
+10 GOTO PICK
+11 ; *********************************************************************
+12 ;
L ; EP
+1 IF '$DATA(^BARRGIT(BARFN))
WRITE !,"NOT BUILT YET !",!
HANG 2
QUIT
+2 DO LIST^BARLNRPT(BARFN)
+3 QUIT
+4 ; *********************************************************************
+5 ;
PICKQ ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
DDPULL(BARFN) ;
+1 ; build array of pointers from DD using truth test in BART
+2 KILL BARDD
+3 SET BARDD=BARFN
+4 DO PULLDD
+5 QUIT
+6 ; *********************************************************************
+7 ;
PULLDD ; EP
+1 ; PULL DD
+2 KILL ^TMP("BARDD",$JOB)
+3 SET BARFD=.001
+4 SET BARFDC=0
+5 FOR
SET BARFD=$ORDER(^DD(BARFN,BARFD))
IF BARFD'>0
QUIT
XECUTE BART
IF $TEST
Begin DoDot:1
+6 IF BARTYP="J"
SET X=$PIECE(@X,U,2)
+7 SET BARFDC=BARFDC+1
+8 SET ^TMP("BARDD",$JOB,BARFDC)=BARFD_"^"_+X
+9 SET ^TMP("BARDD",$JOB,"B",BARFD)=BARFDC
End DoDot:1
+10 QUIT
+11 ; *********************************************************************
+12 ;
E ; EP
+1 ; Edit Items
+2 SET XBSRCFL=+BARFN
+3 KILL DIC,DR,DA
+4 SET DIC=$$DIC^XBDIQ1(90056.3)
+5 SET DIC(0)="AEQML"
+6 DO ^DIC
+7 IF Y'>0
QUIT
+8 KILL ITM
+9 SET ITMDA=+Y
+10 DO DSPITM
+11 SET DIE=DIC
+12 SET DA=ITMDA
+13 SET DR=".01;.04;.05;1.04"
+14 DO ^DIE
+15 DO DSPITM
+16 GOTO E
+17 ; *********************************************************************
+18 ;
DSPITM ; EP
+1 DO ENP^XBDIQ1(90056.3,ITMDA,".01:1.04","ITM(")
+2 WRITE !,"Field |File",?15,ITM(.01)
+3 WRITE !,"Attribute",?15,ITM(.04)
+4 WRITE !,"FM Path",?15,ITM(.05)
+5 WRITE !,"Data Path",?15,ITM(1.04)
+6 WRITE !
+7 QUIT
+8 ; *********************************************************************
+9 ;
JDDSP ;
+1 ; display BARDD for joins field and file pointer
+2 DO DDPULL(BARFN)
+3 WRITE @IOF
+4 SET X=$PIECE(^DIC(BARDD,0),U)_" FILE Fields"
+5 WRITE !,?10,X
+6 SET BARFC=$ORDER(^TMP("BARDD",$JOB,"A"),-1)
+7 SET BARFCH=(BARFC\2)+(BARFC#2)
+8 FOR I=1:1:BARFCH
Begin DoDot:1
+9 SET BARFD=$PIECE(^TMP("BARDD",$JOB,I),U)
+10 SET BARFN0=$PIECE(^TMP("BARDD",$JOB,I),U,2)
+11 WRITE !,$JUSTIFY(I,3),?5,$EXTRACT($PIECE(^DD(BARDD,BARFD,0),U),1,16)
+12 WRITE ?23,$EXTRACT($PIECE(^DIC(BARFN0,0),U),1,16)
+13 SET J=I+BARFCH
+14 IF '$DATA(^TMP("BARDD",$JOB,J))
QUIT
+15 SET BARFD=$PIECE(^TMP("BARDD",$JOB,J),U)
+16 SET BARFN0=$PIECE(^TMP("BARDD",$JOB,J),U,2)
+17 WRITE ?40,$JUSTIFY(J,3),?45,$EXTRACT($PIECE(^DD(BARDD,BARFD,0),U),1,16)
+18 WRITE ?63,$EXTRACT($PIECE(^DIC(BARFN0,0),U),1,16)
End DoDot:1
+19 QUIT
+20 ; *********************************************************************
+21 ;
GDDSP ;
+1 ; display BARDD general 3 columns
+2 DO DDPULL(BARFN)
+3 WRITE @IOF
+4 SET X=$PIECE(^DIC(BARDD,0),U)_" FILE Fields"
+5 WRITE !,?10,X
+6 SET BARFC=$ORDER(^TMP("BARDD",$JOB,"A"),-1)
+7 SET BARFCH=BARFC\3
+8 IF (BARFC#3)
SET BARFCH=BARFCH+1
+9 FOR I=1:1:BARFCH
Begin DoDot:1
+10 SET BARFD=$PIECE(^TMP("BARDD",$JOB,I),U)
+11 WRITE !,$JUSTIFY(I,3),?5,$EXTRACT($PIECE(^DD(BARDD,BARFD,0),U),1,16)
+12 SET J=I+BARFCH
+13 IF '$DATA(^TMP("BARDD",$JOB,J))
QUIT
+14 SET BARFD=$PIECE(^TMP("BARDD",$JOB,J),U)
+15 WRITE ?26,$JUSTIFY(J,3),?31,$EXTRACT($PIECE(^DD(BARDD,BARFD,0),U),1,16)
+16 SET J=2*BARFCH+I
+17 IF '$DATA(^TMP("BARDD",$JOB,J))
QUIT
+18 SET BARFD=$PIECE(^TMP("BARDD",$JOB,J),U)
+19 WRITE ?55,$JUSTIFY(J,3),?60,$EXTRACT($PIECE(^DD(BARDD,BARFD,0),U),1,16)
End DoDot:1
+20 QUIT
+21 ; *********************************************************************
+22 ;
LDDDSP ;
+1 ; display fields already tagged in with BARTYP in the link file
+2 DO DDPULL(BARFN)
+3 KILL BAR,BARLNK,BARLDD
+4 SET BARDD=BARFN
+5 SET BARLDD=BARDD
+6 IF '$DATA(^BARDD(90055.5,BARLDD))
QUIT
+7 KILL DIC
+8 SET DIC=$$DIC^XBDIQ1(90055.51)
+9 SET DIC("S")="I $P(^(0),U,3)[BARTYP"
+10 KILL ^TMP("BARLN",$JOB)
+11 DO ENPM^XBDIQ1(.DIC,"BARDD,0",".01:99","^TMP(""BARLN"",$J,","I")
+12 SET BARFD=0
+13 FOR BARFDC=1:1
SET BARFD=$ORDER(^TMP("BARLN",$JOB,BARFD))
IF BARFD'>0
QUIT
SET BARLDD(BARFDC)=BARFD_"^"_^TMP("BARLN",$JOB,BARFD,.02,"I")
SET BARLDD("B",BARFD)=BARFDC
+14 SET X=$PIECE(^DIC(BARDD,0),U)_" FILE "_BARTYP(BARTYP)
+15 WRITE ?10,X,!
+16 SET BARFC=$ORDER(BARLDD("A"),-1)
+17 SET BARFCH=(BARFC\3)
+18 IF (BARFC#3)
SET BARFCH=BARFCH+1
+19 FOR I=1:1:BARFCH
Begin DoDot:1
+20 SET BARFD=$PIECE(BARLDD(I),U)
SET BARFN0=$PIECE(BARLDD(I),U,2)
+21 WRITE !,$JUSTIFY(^TMP("BARDD",$JOB,"B",BARFD),3),?5,$EXTRACT($PIECE(^DD(BARLDD,BARFD,0),U),1,16)
+22 SET J=I+BARFCH
+23 IF '$DATA(BARLDD(J))
QUIT
+24 SET BARFD=$PIECE(BARLDD(J),U)
+25 SET BARFN0=$PIECE(BARLDD(J),U,2)
+26 WRITE ?26,$JUSTIFY(^TMP("BARDD",$JOB,"B",BARFD),3),?31,$EXTRACT($PIECE(^DD(BARLDD,BARFD,0),U),1,16)
+27 SET J=I+(2*BARFCH)
+28 IF '$DATA(BARLDD(J))
QUIT
+29 SET BARFD=$PIECE(BARLDD(J),U)
+30 SET BARFN0=$PIECE(BARLDD(J),U,2)
+31 WRITE ?55,$JUSTIFY(^TMP("BARDD",$JOB,"B",BARFD),3),?60,$EXTRACT($PIECE(^DD(BARLDD,BARFD,0),U),1,16)
End DoDot:1
+32 WRITE !
+33 QUIT
+34 ; *********************************************************************
+35 ;
ADD ;
+1 ; add pointer to link file entry
+2 ; for back pointers
+3 KILL DIC
+4 IF '$DATA(^BARDD(90055.5,BARDD))
Begin DoDot:1
+5 WRITE !,"file not in join file"
+6 KILL DIR
+7 SET DIR(0)="Y"
+8 SET DIR("B")="Y"
+9 SET DIR("A")="ADD File to link file "
+10 DO ^DIR
+11 KILL DIR
+12 IF 'Y
QUIT
+13 SET DIC=90055.5
+14 SET X=$PIECE(^DIC(BARDD,0),U)
+15 SET DIC(0)="XL"
+16 DO ^DIC
End DoDot:1
+17 IF '$DATA(^BARDD(90055.5,BARDD))
WRITE !,"FILE NOT AVAILABLE",!
HANG 3
QUIT
+18 ;add header
SET $PIECE(^BARDD(90055.5,BARDD,1,0),U,2)="90055.51A"
+19 SET BARFC=$ORDER(^TMP("BARDD",$JOB,"A"),-1)
+20 WRITE !
+21 KILL DIR
+22 SET DIR(0)="LO^1:"_BARFC
+23 SET DIR("A")="Add field(s) to File "_BARTYP(BARTYP)_" entries: "
+24 DO ^DIR
+25 KILL DIR
+26 SET BARY=Y
+27 IF (+Y'>0)
QUIT
+28 SET DIC=$$DIC^XBDIQ1(90055.51)
+29 SET DIC("P")=$PIECE(^DD(90055.5,1,0),"^",2)
+30 SET DA(1)=BARDD
+31 SET DIC(0)="XL"
+32 FOR BARI=1:1
SET BARFDC=$PIECE(BARY,",",BARI)
IF 'BARFDC
QUIT
Begin DoDot:1
+33 SET X=$PIECE(^TMP("BARDD",$JOB,BARFDC),U)
+34 DO ^DIC
+35 SET DA=+Y
+36 SET DA(1)=BARDD
+37 SET BARX=$$VAL^XBDIQ1(90055.51,.DA,.03)
+38 IF BARX[BARTYP
QUIT
+39 KILL DR
+40 IF BARTYP="J"
SET BARFP=$PIECE(^TMP("BARDD",$JOB,BARFDC),U,2)
Begin DoDot:2
+41 SET X="`"_BARFP
+42 SET DIC=$$DIC^XBDIQ1(90055.5)
+43 SET DIC(0)="NXL"
+44 NEW DR
+45 DO ^DIC
End DoDot:2
+46 SET DIE=$$DIC^XBDIQ1(90055.51)
+47 SET DR=".03////"_BARX_BARTYP
+48 IF BARTYP="J"
SET DR=DR_";.02////^S X=BARFP"
+49 DO ^DIE
End DoDot:1
+50 ;
ADDQ ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
DELL ;del entries from link file
+1 QUIT
+2 KILL BAR,BARLNK,BARLDD
+3 SET BARLDD=BARDD
+4 IF '$DATA(^BARDD(90055.5,BARLDD))
QUIT
+5 KILL DIC
+6 SET DIC=$$DIC^XBDIQ1(90055.51)
+7 SET DIC("S")="I $P(^(0),U,3)[BARTYP"
+8 DO ENPM^XBDIQ1(.DIC,"BARDD,0",".01:99","^TMP(""BARLNK"",$J,","I")
+9 SET BARFD=0
+10 FOR BARFDC=1:1
SET BARFD=$ORDER(^TMP("BARLNK",$JOB,BARFD))
IF BARFD'>0
QUIT
SET BARLDD(BARFDC)=BARFD_"^"_^TMP("BARLNK",$JOB,BARFD,.02,"I")
+11 SET X=$PIECE(^DIC(BARDD,0),U)_" FILE "_BARTYP(BARTYP)
+12 WRITE !!,?10,X,!
+13 SET BARFC=$ORDER(BARLDD("A"),-1)
+14 SET BARFCH=(BARFC\3)
+15 IF (BARFC#3)
SET BARFCH=BARFCH+1
+16 FOR I=1:1:BARFCH
Begin DoDot:1
+17 SET J=I
+18 SET BARFD=$PIECE(BARLDD(I),U)
+19 SET BARFN0=$PIECE(BARLDD(I),U,2)
+20 WRITE !,$JUSTIFY(J,3),?5,$EXTRACT($PIECE(^DD(BARLDD,BARFD,0),U),1,16)
+21 SET J=I+BARFCH
+22 IF '$DATA(BARLDD(J))
QUIT
+23 SET BARFD=$PIECE(BARLDD(J),U)
+24 SET BARFN0=$PIECE(BARLDD(J),U,2)
+25 WRITE ?26,$JUSTIFY(J,3),?31,$EXTRACT($PIECE(^DD(BARLDD,BARFD,0),U),1,16)
+26 SET J=I+(2*BARFCH)
+27 IF '$DATA(BARLDD(J))
QUIT
+28 SET BARFD=$PIECE(BARLDD(J),U)
+29 SET BARFN0=$PIECE(BARLDD(J),U,2)
+30 WRITE ?55,$JUSTIFY(J,3),?60,$EXTRACT($PIECE(^DD(BARLDD,BARFD,0),U),1,16)
End DoDot:1
+31 SET BARFC=$ORDER(BARLDD("A"),-1)
+32 QUIT
+33 ; *********************************************************************
+34 ;
QDELL ;EP - DELL ENTRIES
+1 ; for back pointers ;I BARTYP="B" D DELL^BARLNKB Q
+2 KILL DIR
+3 SET DIR(0)="LO^1:"_BARFC
+4 SET DIR("A")="Delete File "_BARTYP(BARTYP)_" Entries: "
+5 DO ^DIR
+6 KILL DIR
+7 IF +Y'>0
QUIT
+8 SET BARY=Y
+9 SET DIE=$$DIC^XBDIQ1(90055.51)
+10 SET DA(1)=BARLDD
+11 FOR BARI=1:1
SET BARX=$PIECE(BARY,",",BARI)
IF BARX'>0
QUIT
SET BARFD=+^TMP("BARDD",$JOB,BARX)
IF $DATA(BARLDD("B",BARFD))
SET DA=BARFD
Begin DoDot:1
+12 SET BARE=$$VAL^XBDIQ1(DIE,.DA,.03)
+13 SET BARE=$TRANSLATE(BARE,BARTYP,"")
+14 IF BARE=""
SET BARE="-"
+15 SET DR=".03////^S X=BARE"
+16 DO ^DIE
End DoDot:1
+17 QUIT
+18 ; *********************************************************************
+19 ;
B ;EP - Back pointers
+1 SET BARTYP="B"
+2 SET XBROU="DISPLAY^BARLNKB"
+3 DO EN^BARLN0
+4 QUIT
+5 ; *********************************************************************
+6 ;
J ;JOINS
JOIN ;;S X=$P(^(BARFD,0),U,3) I ($P(^(0),U)'["*"),X]"",X'[":" S X="^"_X_"0)" I $D(@X)
+1 ;logic to select valid pointer fields only
+2 SET BARTYP="J"
+3 SET BART=$PIECE($TEXT(JOIN^BARLNK),";;",2)
+4 SET XBROU="JLM^BARLNK"
+5 DO EN^BARLN0
+6 QUIT
+7 ; *********************************************************************
+8 ;
JLM ;sequence to generate Join list
+1 DO LDDDSP
DO JDDSP
+2 QUIT
+3 ; *********************************************************************
+4 ;
HSPLM ;sequence to generate hits,sorts,prints list
+1 DO LDDDSP
DO GDDSP
+2 QUIT
+3 ; *********************************************************************
+4 ;
H ;HITS (pointers and sets of codes) for selection
HITS ;;S X=$P(^(BARFD,0),U,3) I X]"",($P(^(0),U)'["*")
+1 SET BARTYP="H"
+2 SET BART=$PIECE($TEXT(HITS^BARLNK),";;",2)
+3 SET XBROU="HSPLM^BARLNK"
+4 DO EN^BARLN0
+5 QUIT
+6 ; *********************************************************************
+7 ;
S ;SORTS (almost all fields , not multiples)
SORTS ;;S X=$P(^(BARFD,0),U,2) I (BARFD=.01)!((X'["A")&(X'["K")&(X'["M")&(X'["W")&(X'=+X)&(X'["F")&($P(^(0),U)'["*"))
+1 SET BARTYP="S"
+2 SET BART=$PIECE($TEXT(SORTS^BARLNK),";;",2)
+3 SET XBROU="HSPLM^BARLNK"
+4 DO EN^BARLN0
+5 QUIT
+6 ; *********************************************************************
+7 ;
P ;PRINTS (almost all fields .. not multiples at this time)
+1 SET BARTYP="P"
+2 SET BART="S X=$P(^(BARFD,0),U) I ($P(^(0),U)'[""*"")"
+3 SET XBROU="HSPLM^BARLNK"
+4 DO EN^BARLN0
+5 QUIT
+6 ; *********************************************************************
+7 ;
W ;Walk from this file and build item entries
TOP ;
+1 SET BARTGDA1=BARFN
SET BARLEV=1
+2 SET XBSRCFL=BARFN
+3 SET BARPATH=""
SET BARFLPTH=""
+4 DO WALK
+5 QUIT
+6 ; *********************************************************************
+7 ;
WALK ;Given BARFN add the fields and then walk the join multiples
+1 DO ^BARLNKW
+2 QUIT
LMFUN ;
