BARLNKW ; IHS/SD/LSL - THE WALKER ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;;
;
W ;
WALK ;Given BARFN add the fields and then walk the join multiples
N BARF0,BARF2,BARFDL,BARLNK
W !,"PROCESSING ",$P(BARPATH,":",2,99)," ",BARFN," ",$P(^DIC(BARFN,0),U)
W !,"adding this files fields to the target's items"
I '$D(^BARDD(90055.5,BARFN,1)) W *7,!!,"NO FIELDS",!! Q
K ^TMP($J,"FLD")
D ENPM^XBDIQ1(90055.51,"BARFN,0",".01:99","^TMP($J,""FLD"",")
K DR,DA,DIE,DIC
S DIC=$$DIC^XBDIQ1(90056.3)
S DIC(0)="LX"
I '$D(^BARRGIT(XBSRCFL,0)) S ^BARRGIT(XBSRCFL,0)="A/R ITEMS (RGEN)^90056.3I^^0"
D DICDR
S DIC("DR")=BARDICDR
S BARFLD=0
F S BARFLD=$O(^TMP($J,"FLD",BARFLD)) Q:BARFLD'>0 D
. S:BARPATH="" BARX1=BARFLD
. S:BARPATH]"" BARX1=$P(BARPATH,":",2,99)_":"_BARFLD
. S BARXNM=^TMP($J,"FLD",BARFLD,.015)
. S BARFLDC=BARXNM_" |"_$$SHRTNM($O(^DD(BARFN,0,"NM","")))
. S BARSFLNM=$$SHRTNM($O(^DD(BARFN,0,"NM","")))
. S $P(BARFLPTH,":",BARLEV)=BARSFLNM,BARFLPTH=$P(BARFLPTH,":",1,BARLEV)
. S BARFLPTH=BARFLPTH_":"_$$SHRTNM(BARXNM)
. S BARBRF=$P(BARFLPTH,":",2,BARLEV+1)
. W !,?(BARLEV*3),BARX1,!,?(BARLEV*3),BARFLDC,!,?(BARLEV*3),BARFLPTH,!
. S X=BARFLDC
. I $D(^BARRGIT(XBSRCFL,"AC",BARX1)) D Q ; if the item exists
.. S DA=$O(^BARRGIT(XBSRCFL,"AC",BARX1,0))
.. S BARDIEDR=".01///^S X=BARFLDC;"_BARDICDR
.. S DIE=$$DIC^XBDIQ1(90056.3)
.. S DR=BARDIEDR
.. D ^DIE
. K DO,DD
. D FILE^DICN
K ^TMP($J,"FLD")
; walk/process the join link files
S DIC=$$DIC^XBDIQ1(90055.51)
S DIC("S")="I $P(^(0),U,3)[""J"""
K ^TMP("BARLNK",$J,BARLEV)
D ENPM^XBDIQ1(.DIC,"BARFN,0",".01:.05","^TMP(""BARLNK"",$J,BARLEV,","I")
S BARFDL=0
F S BARFDL=$O(^TMP("BARLNK",$J,BARLEV,BARFDL)) Q:BARFDL'>0 D
. S BARF0=BARFN
. S BARF2=^TMP("BARLNK",$J,BARLEV,BARFDL,.02,"I")
. S BARFN=BARF2
. S BARFDLL(BARLEV)=BARFDL
. S BARLEV=BARLEV+1
. S $P(BARPATH,":",BARLEV)=BARFDL
. S BARPATH=$P(BARPATH,":",1,BARLEV)
. D WALK ;recursion for walking join multiples
. S BARFN=BARF0
. S BARLEV=BARLEV-1
. S BARFDL=BARFDLL(BARLEV)
. S BARPATH=$P(BARPATH,":",1,BARLEV)
Q
; *********************************************************************
;
DICDR ;build BARDICDR for stuffing fields into items
DR ;;
;;.02////^S X=BARFLD;
;;.03////^S X=BARFN;
;;.04////^S X=^TMP($J,"FLD",BARFLD,.03);
;;.05////^S X=BARX1;
;;.06////^S X=BARLEV;
;;.08////^S X=BARFLDC;
;;1.02////^S X=BARSFLNM;
;;1.03////^S X=BARFLPTH;
;;1.04////^S X=BARBRF;
;;END
S DR=""
F I=1:1 S X=$P($T(DR+I^BARLNKW),";;",2) Q:X="END" S DR=DR_X
S BARDICDR=DR
K DR
;
WALKE ;
Q
; *********************************************************************
;
SHRTNM(X) ;EP - RETURN SHORT NAME FOR TEXT
N I,J,K,L,Y,Z
S L=$L(X),Y=""
F I=1:1:L S Z=$E(X,I) D S Y=Y_Z
. I I=1 Q
. I $E(X,I-1)=$C(32) Q
. I Z=" " S Z="_" Q
. I Z=$E(X,I-1) S Z="" Q
. I "AEIOUaeiou"[Z S Z=""
;
ESHRT ;
Q Y
BARLNKW ; IHS/SD/LSL - THE WALKER ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;;
+3 ;
W ;
WALK ;Given BARFN add the fields and then walk the join multiples
+1 NEW BARF0,BARF2,BARFDL,BARLNK
+2 WRITE !,"PROCESSING ",$PIECE(BARPATH,":",2,99)," ",BARFN," ",$PIECE(^DIC(BARFN,0),U)
+3 WRITE !,"adding this files fields to the target's items"
+4 IF '$DATA(^BARDD(90055.5,BARFN,1))
WRITE *7,!!,"NO FIELDS",!!
QUIT
+5 KILL ^TMP($JOB,"FLD")
+6 DO ENPM^XBDIQ1(90055.51,"BARFN,0",".01:99","^TMP($J,""FLD"",")
+7 KILL DR,DA,DIE,DIC
+8 SET DIC=$$DIC^XBDIQ1(90056.3)
+9 SET DIC(0)="LX"
+10 IF '$DATA(^BARRGIT(XBSRCFL,0))
SET ^BARRGIT(XBSRCFL,0)="A/R ITEMS (RGEN)^90056.3I^^0"
+11 DO DICDR
+12 SET DIC("DR")=BARDICDR
+13 SET BARFLD=0
+14 FOR
SET BARFLD=$ORDER(^TMP($JOB,"FLD",BARFLD))
IF BARFLD'>0
QUIT
Begin DoDot:1
+15 IF BARPATH=""
SET BARX1=BARFLD
+16 IF BARPATH]""
SET BARX1=$PIECE(BARPATH,":",2,99)_":"_BARFLD
+17 SET BARXNM=^TMP($JOB,"FLD",BARFLD,.015)
+18 SET BARFLDC=BARXNM_" |"_$$SHRTNM($ORDER(^DD(BARFN,0,"NM","")))
+19 SET BARSFLNM=$$SHRTNM($ORDER(^DD(BARFN,0,"NM","")))
+20 SET $PIECE(BARFLPTH,":",BARLEV)=BARSFLNM
SET BARFLPTH=$PIECE(BARFLPTH,":",1,BARLEV)
+21 SET BARFLPTH=BARFLPTH_":"_$$SHRTNM(BARXNM)
+22 SET BARBRF=$PIECE(BARFLPTH,":",2,BARLEV+1)
+23 WRITE !,?(BARLEV*3),BARX1,!,?(BARLEV*3),BARFLDC,!,?(BARLEV*3),BARFLPTH,!
+24 SET X=BARFLDC
+25 ; if the item exists
IF $DATA(^BARRGIT(XBSRCFL,"AC",BARX1))
Begin DoDot:2
+26 SET DA=$ORDER(^BARRGIT(XBSRCFL,"AC",BARX1,0))
+27 SET BARDIEDR=".01///^S X=BARFLDC;"_BARDICDR
+28 SET DIE=$$DIC^XBDIQ1(90056.3)
+29 SET DR=BARDIEDR
+30 DO ^DIE
End DoDot:2
QUIT
+31 KILL DO,DD
+32 DO FILE^DICN
End DoDot:1
+33 KILL ^TMP($JOB,"FLD")
+34 ; walk/process the join link files
+35 SET DIC=$$DIC^XBDIQ1(90055.51)
+36 SET DIC("S")="I $P(^(0),U,3)[""J"""
+37 KILL ^TMP("BARLNK",$JOB,BARLEV)
+38 DO ENPM^XBDIQ1(.DIC,"BARFN,0",".01:.05","^TMP(""BARLNK"",$J,BARLEV,","I")
+39 SET BARFDL=0
+40 FOR
SET BARFDL=$ORDER(^TMP("BARLNK",$JOB,BARLEV,BARFDL))
IF BARFDL'>0
QUIT
Begin DoDot:1
+41 SET BARF0=BARFN
+42 SET BARF2=^TMP("BARLNK",$JOB,BARLEV,BARFDL,.02,"I")
+43 SET BARFN=BARF2
+44 SET BARFDLL(BARLEV)=BARFDL
+45 SET BARLEV=BARLEV+1
+46 SET $PIECE(BARPATH,":",BARLEV)=BARFDL
+47 SET BARPATH=$PIECE(BARPATH,":",1,BARLEV)
+48 ;recursion for walking join multiples
DO WALK
+49 SET BARFN=BARF0
+50 SET BARLEV=BARLEV-1
+51 SET BARFDL=BARFDLL(BARLEV)
+52 SET BARPATH=$PIECE(BARPATH,":",1,BARLEV)
End DoDot:1
+53 QUIT
+54 ; *********************************************************************
+55 ;
DICDR ;build BARDICDR for stuffing fields into items
DR ;;
+1 ;;.02////^S X=BARFLD;
+2 ;;.03////^S X=BARFN;
+3 ;;.04////^S X=^TMP($J,"FLD",BARFLD,.03);
+4 ;;.05////^S X=BARX1;
+5 ;;.06////^S X=BARLEV;
+6 ;;.08////^S X=BARFLDC;
+7 ;;1.02////^S X=BARSFLNM;
+8 ;;1.03////^S X=BARFLPTH;
+9 ;;1.04////^S X=BARBRF;
+10 ;;END
+11 SET DR=""
+12 FOR I=1:1
SET X=$PIECE($TEXT(DR+I^BARLNKW),";;",2)
IF X="END"
QUIT
SET DR=DR_X
+13 SET BARDICDR=DR
+14 KILL DR
+15 ;
WALKE ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
SHRTNM(X) ;EP - RETURN SHORT NAME FOR TEXT
+1 NEW I,J,K,L,Y,Z
+2 SET L=$LENGTH(X)
SET Y=""
+3 FOR I=1:1:L
SET Z=$EXTRACT(X,I)
Begin DoDot:1
+4 IF I=1
QUIT
+5 IF $EXTRACT(X,I-1)=$CHAR(32)
QUIT
+6 IF Z=" "
SET Z="_"
QUIT
+7 IF Z=$EXTRACT(X,I-1)
SET Z=""
QUIT
+8 IF "AEIOUaeiou"[Z
SET Z=""
End DoDot:1
SET Y=Y_Z
+9 ;
ESHRT ;
+1 QUIT Y
