IB20PT88 ;ALB/CPM - EXPORT ROUTINE 'DG3PR0' ; 24-FEB-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DG3PR0 ;ALB/JDS - 10-10I ;01 JAN 1987
;;5.3;Registration;**26**;Aug 13, 1993
START K ^UTILITY($J) S (N(1),N(0),DG(1),DG(0))="" D ALL^IBCNS1(DFN,"DGIBINS") F I=0:0 S I=$O(DGIBINS(I)) Q:'I S L=DGIBINS(I,0),M=$P(L,U,6),M=$S(M']"":0,1:M),^UTILITY($J,M,I)=L
F I="v",0,"s","o" I $D(^UTILITY($J,I)) S DG(0)=^($O(^(I,0))),N(0)=I Q
F I="v",0,"s","o" I $D(^UTILITY($J,I)) S L=$S(N(0)=I:$O(^($O(^(I,0)))),1:$O(^(I,0))) I L>0 S DG(1)=^UTILITY($J,I,L),N(1)=I Q
;K ^UTILITY($J)
PRINT ;
G:$$FIRST^DGUTL Q
I '$D(DGNOW) N DGNOW D NOW^%DTC,YX^%DTC S DGNOW=Y
W "Printed: ",DGNOW
S DIC(0)="LM",X="DG1010I",DIC="^DIC(47," D ^DIC G Q:Y'>0 S DGY=+Y
F I=0,.21,.22,.25,.311 S D(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S Y=$P(D(.22),U,5) D ZIPOUT^VAFADDR S X=$P(D(.311),U,6,7)_U_Y D AD2 S D(.311)=$P(D(.311),U,1)_U_$P(D(.311),U,9)_U_$P(D(.311),U,3)_" "_$P(D(.311),U,4)_" "_$P(D(.311),U,5)_U_X
S Y=$P(D(.22),U,6) D ZIPOUT^VAFADDR S X=$P(D(.25),U,5,6)_U_Y D AD2 S D(.25)=$P(D(.25),U,1)_U_$P(D(.25),U,8)_U_$P(D(.25),U,2)_" "_$P(D(.25),U,3)_" "_$P(D(.25),U,4)_U_X
F I=0,1 D SET
S (L,DGL)=0 F I=0:0 S I=$O(^DIC(47,+DGY,1,I)) Q:'I!(DGL=I) S J=^(I,0),X="" W ! F K=1:1 W $E($P(J,"{}",K),$S(K=1:1,X']"":1,1:$L(X)-1),999) S X=$P(J,"{",K+1) Q:X']"" S L=L+1 D SE W:X']"" " "
Q D ENDREP^DGUTL K A,B,D,DG,DGL,DGY,DIC,E,I,J,K,L,M,N,X,X1,X2,Y,DGIBINS,^UTILITY($J)
Q
SET S A=DG(I),A=$S($D(^DIC(36,+A,0)):^(0),1:""),B=$G(^DIC(36,+DG(I),.11)),Y=$P(B,U,6) D ZIPOUT^VAFADDR S X=$P(B,U,4,5)_U_Y D AD2
S X(I)=$P(A,U,1)_U_$P($G(^DIC(36,+DG(I),.13)),U,1)_U_$P(B,U,1)_U_X_U_$P(DG(I),U,2)_U_$P(DG(I),U,3)_U,Y=$P(DG(I),U,8) X ^DD("DD") S X(I)=X(I)_Y_U,Y=$P(DG(I),U,7) X ^DD("DD") S X(I)=X(I)_Y
S N=$S(N(I)="s":$P(DG(I),U,17)_U_"SPOUSE",(N(I)=0!(N(I)="v")):$P(D(0),U,1)_U_"SAME",1:$P(DG(I),U,17)_U)
S E=$S(N(I)=0!(N(I)="v"):D(.311),N(I)="s":D(.25),1:"^^^^")
S X=$P(DG(I),U,12,14) D AD2 S X1(I)=N_U_E,X2(I)=$P(DG(I),U,9,11)_U_X
Q
AD2 S X=$P(X,U,1)_$S($P(X,U,1)]"":", ",1:"")_$S($D(^DIC(5,+$P(X,U,2),0)):$P(^(0),U,1),1:"")_" "_$P(X,U,3) Q
SE I L>2&(L<11) S X=$P(X(L\21),U,L-$S(L>20:20,1:2)) W X Q
I L>10&(L<17) S X=$P(X1(L\21),U,L-10) W X Q
I L>16&(L<21) S X=$P(X2(L\21),U,L-16) W X Q
I L>20&(L<29) S X=$P(X(L\21),U,L-20) W X Q
I L>28&(L<35) S X=$P(X1(L\21),U,L-28) W X Q
I L>34 S X=$P(X2(L\21),U,L-34) W X Q
S X=$P(D(0),U,$S(L=1:1,1:9)) W X Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20PT88 2456 printed Nov 22, 2024@17:15:41 Page 2
IB20PT88 ;ALB/CPM - EXPORT ROUTINE 'DG3PR0' ; 24-FEB-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DG3PR0 ;ALB/JDS - 10-10I ;01 JAN 1987
+1 ;;5.3;Registration;**26**;Aug 13, 1993
START KILL ^UTILITY($JOB)
SET (N(1),N(0),DG(1),DG(0))=""
DO ALL^IBCNS1(DFN,"DGIBINS")
FOR I=0:0
SET I=$ORDER(DGIBINS(I))
if 'I
QUIT
SET L=DGIBINS(I,0)
SET M=$PIECE(L,U,6)
SET M=$SELECT(M']"":0,1:M)
SET ^UTILITY($JOB,M,I)=L
+1 FOR I="v",0,"s","o"
IF $DATA(^UTILITY($JOB,I))
SET DG(0)=^($ORDER(^(I,0)))
SET N(0)=I
QUIT
+2 FOR I="v",0,"s","o"
IF $DATA(^UTILITY($JOB,I))
SET L=$SELECT(N(0)=I:$ORDER(^($ORDER(^(I,0)))),1:$ORDER(^(I,0)))
IF L>0
SET DG(1)=^UTILITY($JOB,I,L)
SET N(1)=I
QUIT
+3 ;K ^UTILITY($J)
PRINT ;
+1 if $$FIRST^DGUTL
GOTO Q
+2 IF '$DATA(DGNOW)
NEW DGNOW
DO NOW^%DTC
DO YX^%DTC
SET DGNOW=Y
+3 WRITE "Printed: ",DGNOW
+4 SET DIC(0)="LM"
SET X="DG1010I"
SET DIC="^DIC(47,"
DO ^DIC
if Y'>0
GOTO Q
SET DGY=+Y
+5 FOR I=0,.21,.22,.25,.311
SET D(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+6 SET Y=$PIECE(D(.22),U,5)
DO ZIPOUT^VAFADDR
SET X=$PIECE(D(.311),U,6,7)_U_Y
DO AD2
SET D(.311)=$PIECE(D(.311),U,1)_U_$PIECE(D(.311),U,9)_U_$PIECE(D(.311),U,3)_" "_$PIECE(D(.311),U,4)_" "_$PIECE(D(.311),U,5)_U_X
+7 SET Y=$PIECE(D(.22),U,6)
DO ZIPOUT^VAFADDR
SET X=$PIECE(D(.25),U,5,6)_U_Y
DO AD2
SET D(.25)=$PIECE(D(.25),U,1)_U_$PIECE(D(.25),U,8)_U_$PIECE(D(.25),U,2)_" "_$PIECE(D(.25),U,3)_" "_$PIECE(D(.25),U,4)_U_X
+8 FOR I=0,1
DO SET
+9 SET (L,DGL)=0
FOR I=0:0
SET I=$ORDER(^DIC(47,+DGY,1,I))
if 'I!(DGL=I)
QUIT
SET J=^(I,0)
SET X=""
WRITE !
FOR K=1:1
WRITE $EXTRACT($PIECE(J,"{}",K),$SELECT(K=1:1,X']"":1,1:$LENGTH(X)-1),999)
SET X=$PIECE(J,"{",K+1)
if X']""
QUIT
SET L=L+1
DO SE
if X']""
WRITE " "
Q DO ENDREP^DGUTL
KILL A,B,D,DG,DGL,DGY,DIC,E,I,J,K,L,M,N,X,X1,X2,Y,DGIBINS,^UTILITY($JOB)
+1 QUIT
SET SET A=DG(I)
SET A=$SELECT($DATA(^DIC(36,+A,0)):^(0),1:"")
SET B=$GET(^DIC(36,+DG(I),.11))
SET Y=$PIECE(B,U,6)
DO ZIPOUT^VAFADDR
SET X=$PIECE(B,U,4,5)_U_Y
DO AD2
+1 SET X(I)=$PIECE(A,U,1)_U_$PIECE($GET(^DIC(36,+DG(I),.13)),U,1)_U_$PIECE(B,U,1)_U_X_U_$PIECE(DG(I),U,2)_U_$PIECE(DG(I),U,3)_U
SET Y=$PIECE(DG(I),U,8)
XECUTE ^DD("DD")
SET X(I)=X(I)_Y_U
SET Y=$PIECE(DG(I),U,7)
XECUTE ^DD("DD")
SET X(I)=X(I)_Y
+2 SET N=$SELECT(N(I)="s":$PIECE(DG(I),U,17)_U_"SPOUSE",(N(I)=0!(N(I)="v")):$PIECE(D(0),U,1)_U_"SAME",1:$PIECE(DG(I),U,17)_U)
+3 SET E=$SELECT(N(I)=0!(N(I)="v"):D(.311),N(I)="s":D(.25),1:"^^^^")
+4 SET X=$PIECE(DG(I),U,12,14)
DO AD2
SET X1(I)=N_U_E
SET X2(I)=$PIECE(DG(I),U,9,11)_U_X
+5 QUIT
AD2 SET X=$PIECE(X,U,1)_$SELECT($PIECE(X,U,1)]"":", ",1:"")_$SELECT($DATA(^DIC(5,+$PIECE(X,U,2),0)):$PIECE(^(0),U,1),1:"")_" "_$PIECE(X,U,3)
QUIT
SE IF L>2&(L<11)
SET X=$PIECE(X(L\21),U,L-$SELECT(L>20:20,1:2))
WRITE X
QUIT
+1 IF L>10&(L<17)
SET X=$PIECE(X1(L\21),U,L-10)
WRITE X
QUIT
+2 IF L>16&(L<21)
SET X=$PIECE(X2(L\21),U,L-16)
WRITE X
QUIT
+3 IF L>20&(L<29)
SET X=$PIECE(X(L\21),U,L-20)
WRITE X
QUIT
+4 IF L>28&(L<35)
SET X=$PIECE(X1(L\21),U,L-28)
WRITE X
QUIT
+5 IF L>34
SET X=$PIECE(X2(L\21),U,L-34)
WRITE X
QUIT
+6 SET X=$PIECE(D(0),U,$SELECT(L=1:1,1:9))
WRITE X
QUIT
+7 QUIT
