PRCBE0 ;WISC@ALTOONA/CTB-285 DISTRIBUTION ;4/14/93 11:27 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
OUT K %,%X,%Y,D,D0,D1,D2,DD,DO,DQ,DA,DIC,DIE,DLAYGO,DQ,DR,DWLW,I,J,X,Y Q
;
EN4 ;DISTRIBUTION OF RD 2-285 DATA
S PRCF("X")="AB" D ^PRCFSITE G:'% OUT4
EN41 S DIC("A")="Select TDA NUMBER FOR STATION "_PRC("SITE")_", FY "_PRC("FY")_": "
S DIC("S")="S ZX=^(0) I $P(ZX,U,16)]"""",$P(ZX,""-"",1,2)=PRCF(""SIFY"")",DIC="^PRCF(421,",DIC(0)="AEQXZ",D="C" D IX^DIC K DIC,ZX,D G:+Y<0 OUT4 S DA=+Y,DIE="^PRCF(421,"
I $P(Y(0),U,4)="" W !,"TRANSACTION NUMBER ",X," DOES NOT CONTAIN A TDA NUMBER, AND THEREFORE",!,"MAY NOT BE DISTRIBUTED FOR THE RD 2 285 REPORT",$C(7),! G EN41
F I=1:1:4 S PX(I)=$P(Y(0),U,I+6) I PX(I)="" S PX(I)=0
EN42 W !!,"TDA IS DISTRIBUTED AS FOLLOWS: "
S PX="1ST QTR^2ND QTR^3RD QTR^4TH QTR" W !! F I=1:1:4 W ?$X+10,$P(PX,U,I)
W !! F I=1:1:4 W ?$X+2,$J(PX(I),15,0)
W !!,"ENTER THE NON CUMULATIVE DISTRIBUTION FOR THIS TDA"
W ! S DR="[PRCB RD2-285 ALL]",PY="" D ^DIE I $D(Y)'=0 D OUT4,OUT Q
S:'$D(^PRCF(421,DA,3)) ^(3)="" S Q=^(3),Q(0)=0 F I=1:1:12 S Q(I)=Q(I-1)+$P(Q,U,I)
F I=1:1:4 S Q(I+20)=Q(I*3)-Q(I-1*3)
F I=1:1:4 I +Q(I+20)'=+PX(I) W !,"CUMULATIVE TOTAL FOR ",$P(PX,U,I)," IS NOT CORRECT",!,$C(7) S I(1)=1
I $D(I(1)) K I W ! S %A="DO YOU WISH TO MAKE CORRECTIONS AT THIS TIME",%B="",%=1 D ^PRCFYN G:%=1 EN42 D OUT4 G OUT
S Q="" K I F I=1:1:12 S Q=Q_Q(I)_U
S ^PRCF(421,DA,2)=Q K I,J,Q,P,X,Y W !!,"DISTRIBUTION IS CORRECT BY QUARTER ",!! G EN41
OUT4 K I,J,Q,P,X,Y,PRCF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBE0 1576 printed Oct 16, 2024@18:01:25 Page 2
PRCBE0 ;WISC@ALTOONA/CTB-285 DISTRIBUTION ;4/14/93 11:27 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
OUT KILL %,%X,%Y,D,D0,D1,D2,DD,DO,DQ,DA,DIC,DIE,DLAYGO,DQ,DR,DWLW,I,J,X,Y
QUIT
+1 ;
EN4 ;DISTRIBUTION OF RD 2-285 DATA
+1 SET PRCF("X")="AB"
DO ^PRCFSITE
if '%
GOTO OUT4
EN41 SET DIC("A")="Select TDA NUMBER FOR STATION "_PRC("SITE")_", FY "_PRC("FY")_": "
+1 SET DIC("S")="S ZX=^(0) I $P(ZX,U,16)]"""",$P(ZX,""-"",1,2)=PRCF(""SIFY"")"
SET DIC="^PRCF(421,"
SET DIC(0)="AEQXZ"
SET D="C"
DO IX^DIC
KILL DIC,ZX,D
if +Y<0
GOTO OUT4
SET DA=+Y
SET DIE="^PRCF(421,"
+2 IF $PIECE(Y(0),U,4)=""
WRITE !,"TRANSACTION NUMBER ",X," DOES NOT CONTAIN A TDA NUMBER, AND THEREFORE",!,"MAY NOT BE DISTRIBUTED FOR THE RD 2 285 REPORT",$CHAR(7),!
GOTO EN41
+3 FOR I=1:1:4
SET PX(I)=$PIECE(Y(0),U,I+6)
IF PX(I)=""
SET PX(I)=0
EN42 WRITE !!,"TDA IS DISTRIBUTED AS FOLLOWS: "
+1 SET PX="1ST QTR^2ND QTR^3RD QTR^4TH QTR"
WRITE !!
FOR I=1:1:4
WRITE ?$X+10,$PIECE(PX,U,I)
+2 WRITE !!
FOR I=1:1:4
WRITE ?$X+2,$JUSTIFY(PX(I),15,0)
+3 WRITE !!,"ENTER THE NON CUMULATIVE DISTRIBUTION FOR THIS TDA"
+4 WRITE !
SET DR="[PRCB RD2-285 ALL]"
SET PY=""
DO ^DIE
IF $DATA(Y)'=0
DO OUT4
DO OUT
QUIT
+5 if '$DATA(^PRCF(421,DA,3))
SET ^(3)=""
SET Q=^(3)
SET Q(0)=0
FOR I=1:1:12
SET Q(I)=Q(I-1)+$PIECE(Q,U,I)
+6 FOR I=1:1:4
SET Q(I+20)=Q(I*3)-Q(I-1*3)
+7 FOR I=1:1:4
IF +Q(I+20)'=+PX(I)
WRITE !,"CUMULATIVE TOTAL FOR ",$PIECE(PX,U,I)," IS NOT CORRECT",!,$CHAR(7)
SET I(1)=1
+8 IF $DATA(I(1))
KILL I
WRITE !
SET %A="DO YOU WISH TO MAKE CORRECTIONS AT THIS TIME"
SET %B=""
SET %=1
DO ^PRCFYN
if %=1
GOTO EN42
DO OUT4
GOTO OUT
+9 SET Q=""
KILL I
FOR I=1:1:12
SET Q=Q_Q(I)_U
+10 SET ^PRCF(421,DA,2)=Q
KILL I,J,Q,P,X,Y
WRITE !!,"DISTRIBUTION IS CORRECT BY QUARTER ",!!
GOTO EN41
OUT4 KILL I,J,Q,P,X,Y,PRCF
QUIT
