- 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 Mar 13, 2025@21:10:24 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
