- 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 Feb 18, 2025@23:27:03 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
