Routine: BARLNK

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)

 ; *********************************************************************

PICKQ ;

 ; *********************************************************************

DDPULL(BARFN) ;

 ; build array of pointers  from DD using truth test in BART

 K BARDD

 S BARDD=BARFN

 D PULLDD

 ; *********************************************************************

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

 ; *********************************************************************

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 !

 ; *********************************************************************

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)

 ; *********************************************************************

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)

 ; *********************************************************************

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 !

 ; *********************************************************************

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 ;

 ; *********************************************************************

DELL ;del entries from link file

 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)

 ; *********************************************************************

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

 ; *********************************************************************

B ;EP - Back pointers

 S BARTYP="B"

 S XBROU="DISPLAY^BARLNKB"

 D EN^BARLN0

 ; *********************************************************************

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

 ; *********************************************************************

JLM ;sequence to generate Join list

 D LDDDSP,JDDSP

 ; *********************************************************************

HSPLM ;sequence to generate hits,sorts,prints list

 D LDDDSP,GDDSP

 ; *********************************************************************

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

 ; *********************************************************************

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

 ; *********************************************************************

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

 ; *********************************************************************

W ;Walk from this file and build item entries

TOP ;

 S BARTGDA1=BARFN,BARLEV=1

 S XBSRCFL=BARFN

 S BARPATH="",BARFLPTH=""

 D WALK

 ; *********************************************************************

WALK ;Given BARFN add the fields and then walk the join multiples

 D ^BARLNKW

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     ;

BARLNK.m