source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFUOMS.m@ 1076

Last change on this file since 1076 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.0 KB
RevLine 
[613]1PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
2V ;;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
11EXIT 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
13B 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
15SUB 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
19C 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
Note: See TracBrowser for help on using the repository browser.