- PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
- V ;;5.1;IFCAP;**106**;Oct 20, 2000
- ;Per VHA Directive 2004-038, this routine should not be modified.
- S (PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT)=0,L=0
- S DIC="^PRC(442,",DHD="850 UNDELIVERED ORDERS FOR MANDATED SOURCES"
- S FLDS="[PRCFUOMS]",BY="[PRCFUOMS]",DIOEND="D B^PRCFUOMS"
- S DIS(0)="I $D(^PRC(442,D0,0)),$O(^PRC(442,D0,22,0))>0 I $P(^PRC(442,D0,0),U,17)'=$P(^(0),U,16)"
- S PRCFI=";30;31;33;37;38;40;41;45;48;49;"
- S DIS(1)="I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"") D C^PRCFUOMS I PRCFU>.01"
- D EN1^DIP
- EXIT K PRCFS,PRCFS1,PRCFO,PRCFO1,PRCFC,PRCFA,PRCFA1,PRCFI,PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT,PRCFTOT,PRCFII,PRCFLAG,PRCFSS,PRCFU,PRCTDT,PRCFAP,ZBOC
- Q
- B S PRCFB=1 D SUB W !!,?14,"TOTAL NUMBER RECORDS ",PRCFCT,?58,"TOTALS $",?71,$J(PRCFOT,12,2),?85,$J(PRCFAT,12,2),?100,$J(PRCFOT-PRCFAT,12,2)
- K PRCFAP,PRCFCAP,PRCFB,PRCFAS,PRCFOS,PRCFUS,PRCFCS,PRCFAT,PRCFCT,PRCFOT Q
- SUB I 'PRCFCT W !!
- S PRCFUS=PRCFOS-PRCFAS W ?71,"------------",?85,"------------",?100,"------------",!,?20,"NUMBER RECORDS ",PRCFCS,?55,"SUBTOTALS $",?71,$J(PRCFOS,12,2),?85,$J(PRCFAS,12,2),?100,$J(PRCFUS,12,2)
- W:'$D(PRCFB) !!,?11,"APPROPRIATION: ",PRCFCAP S (PRCFCS,PRCFOS,PRCFAS)=0
- Q
- C S (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0 N I
- S PRCFMULT=100-$P($G(^PRC(442,D0,5,1,0)),U,1)/100
- S PRCFSHIP=$P($G(^PRC(442,D0,0)),U,13)
- S PRCFSBOC=+$P($G(^PRC(442,D0,23)),U,1)
- K PRCFLAG F I=0:0 S I=$O(^PRC(442,D0,22,I)) Q:PRCFU>.01!(I'>0) I $D(^PRC(442,D0,22,I,0)),+$P(^(0),U,1)'=0 S PRCFS=$P(^(0),U,1),PRCFO=$P(^(0),U,2) D
- . S (PRCFA1,PRCFJ)=0
- . F S PRCFJ=$O(^PRC(442,D0,2,PRCFJ)) Q:PRCFJ'>0 I $D(^(PRCFJ,0)),$P(^PRC(442,D0,2,PRCFJ,0),U,4)'="" S PRCFSS=$P(^(0),U,4) I +PRCFS=+PRCFSS D
- . . K PRCFTOT F PRCFII=0:0 S PRCFII=$O(^PRC(442,D0,2,PRCFJ,3,PRCFII)) Q:PRCFII'>0 I $D(^(PRCFII,0)),$P(^(0),U,3) S PRCFA=$P(^(0),U,3)-$P(^(0),U,5),PRCFA1=PRCFA1+PRCFA
- . S PRCFA1=PRCFA1*PRCFMULT,PRCFU=PRCFO-PRCFA1
- . I PRCFU>.01,PRCFA1,PRCFSBOC=PRCFS S PRCFU=PRCFU-PRCFSHIP
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFUOMS 2109 printed Jan 18, 2025@03:05:42 Page 2
- PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
- V ;;5.1;IFCAP;**106**;Oct 20, 2000
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 SET (PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT)=0
- SET L=0
- +3 SET DIC="^PRC(442,"
- SET DHD="850 UNDELIVERED ORDERS FOR MANDATED SOURCES"
- +4 SET FLDS="[PRCFUOMS]"
- SET BY="[PRCFUOMS]"
- SET DIOEND="D B^PRCFUOMS"
- +5 SET DIS(0)="I $D(^PRC(442,D0,0)),$O(^PRC(442,D0,22,0))>0 I $P(^PRC(442,D0,0),U,17)'=$P(^(0),U,16)"
- +6 SET PRCFI=";30;31;33;37;38;40;41;45;48;49;"
- +7 SET DIS(1)="I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"") D C^PRCFUOMS I PRCFU>.01"
- +8 DO EN1^DIP
- EXIT KILL PRCFS,PRCFS1,PRCFO,PRCFO1,PRCFC,PRCFA,PRCFA1,PRCFI,PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT,PRCFTOT,PRCFII,PRCFLAG,PRCFSS,PRCFU,PRCTDT,PRCFAP,ZBOC
- +1 QUIT
- B SET PRCFB=1
- DO SUB
- WRITE !!,?14,"TOTAL NUMBER RECORDS ",PRCFCT,?58,"TOTALS $",?71,$JUSTIFY(PRCFOT,12,2),?85,$JUSTIFY(PRCFAT,12,2),?100,$JUSTIFY(PRCFOT-PRCFAT,12,2)
- +1 KILL PRCFAP,PRCFCAP,PRCFB,PRCFAS,PRCFOS,PRCFUS,PRCFCS,PRCFAT,PRCFCT,PRCFOT
- QUIT
- SUB IF 'PRCFCT
- WRITE !!
- +1 SET PRCFUS=PRCFOS-PRCFAS
- WRITE ?71,"------------",?85,"------------",?100,"------------",!,?20,"NUMBER RECORDS ",PRCFCS,?55,"SUBTOTALS $",?71,$JUSTIFY(PRCFOS,12,2),?85,$JUSTIFY(PRCFAS,12,2),?100,$JUSTIFY(PRCFUS,12,2)
- +2 if '$DATA(PRCFB)
- WRITE !!,?11,"APPROPRIATION: ",PRCFCAP
- SET (PRCFCS,PRCFOS,PRCFAS)=0
- +3 QUIT
- C SET (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0
- NEW I
- +1 SET PRCFMULT=100-$PIECE($GET(^PRC(442,D0,5,1,0)),U,1)/100
- +2 SET PRCFSHIP=$PIECE($GET(^PRC(442,D0,0)),U,13)
- +3 SET PRCFSBOC=+$PIECE($GET(^PRC(442,D0,23)),U,1)
- +4 KILL PRCFLAG
- FOR I=0:0
- SET I=$ORDER(^PRC(442,D0,22,I))
- if PRCFU>.01!(I'>0)
- QUIT
- IF $DATA(^PRC(442,D0,22,I,0))
- IF +$PIECE(^(0),U,1)'=0
- SET PRCFS=$PIECE(^(0),U,1)
- SET PRCFO=$PIECE(^(0),U,2)
- Begin DoDot:1
- +5 SET (PRCFA1,PRCFJ)=0
- +6 FOR
- SET PRCFJ=$ORDER(^PRC(442,D0,2,PRCFJ))
- if PRCFJ'>0
- QUIT
- IF $DATA(^(PRCFJ,0))
- IF $PIECE(^PRC(442,D0,2,PRCFJ,0),U,4)'=""
- SET PRCFSS=$PIECE(^(0),U,4)
- IF +PRCFS=+PRCFSS
- Begin DoDot:2
- +7 KILL PRCFTOT
- FOR PRCFII=0:0
- SET PRCFII=$ORDER(^PRC(442,D0,2,PRCFJ,3,PRCFII))
- if PRCFII'>0
- QUIT
- IF $DATA(^(PRCFII,0))
- IF $PIECE(^(0),U,3)
- SET PRCFA=$PIECE(^(0),U,3)-$PIECE(^(0),U,5)
- SET PRCFA1=PRCFA1+PRCFA
- End DoDot:2
- +8 SET PRCFA1=PRCFA1*PRCFMULT
- SET PRCFU=PRCFO-PRCFA1
- +9 IF PRCFU>.01
- IF PRCFA1
- IF PRCFSBOC=PRCFS
- SET PRCFU=PRCFU-PRCFSHIP
- End DoDot:1
- +10 QUIT