| 1 | PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
|
|---|
| 2 | V ;;5.1;IFCAP;**106**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | S (PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT)=0,L=0
|
|---|
| 5 | S DIC="^PRC(442,",DHD="850 UNDELIVERED ORDERS FOR MANDATED SOURCES"
|
|---|
| 6 | S FLDS="[PRCFUOMS]",BY="[PRCFUOMS]",DIOEND="D B^PRCFUOMS"
|
|---|
| 7 | 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)"
|
|---|
| 8 | S PRCFI=";30;31;33;37;38;40;41;45;48;49;"
|
|---|
| 9 | S DIS(1)="I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"") D C^PRCFUOMS I PRCFU>.01"
|
|---|
| 10 | D EN1^DIP
|
|---|
| 11 | EXIT K PRCFS,PRCFS1,PRCFO,PRCFO1,PRCFC,PRCFA,PRCFA1,PRCFI,PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT,PRCFTOT,PRCFII,PRCFLAG,PRCFSS,PRCFU,PRCTDT,PRCFAP,ZBOC
|
|---|
| 12 | Q
|
|---|
| 13 | 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)
|
|---|
| 14 | K PRCFAP,PRCFCAP,PRCFB,PRCFAS,PRCFOS,PRCFUS,PRCFCS,PRCFAT,PRCFCT,PRCFOT Q
|
|---|
| 15 | SUB I 'PRCFCT W !!
|
|---|
| 16 | 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)
|
|---|
| 17 | W:'$D(PRCFB) !!,?11,"APPROPRIATION: ",PRCFCAP S (PRCFCS,PRCFOS,PRCFAS)=0
|
|---|
| 18 | Q
|
|---|
| 19 | C S (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0 N I
|
|---|
| 20 | S PRCFMULT=100-$P($G(^PRC(442,D0,5,1,0)),U,1)/100
|
|---|
| 21 | S PRCFSHIP=$P($G(^PRC(442,D0,0)),U,13)
|
|---|
| 22 | S PRCFSBOC=+$P($G(^PRC(442,D0,23)),U,1)
|
|---|
| 23 | 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
|
|---|
| 24 | . S (PRCFA1,PRCFJ)=0
|
|---|
| 25 | . 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
|
|---|
| 26 | . . 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
|
|---|
| 27 | . S PRCFA1=PRCFA1*PRCFMULT,PRCFU=PRCFO-PRCFA1
|
|---|
| 28 | . I PRCFU>.01,PRCFA1,PRCFSBOC=PRCFS S PRCFU=PRCFU-PRCFSHIP
|
|---|
| 29 | Q
|
|---|
