source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFUO.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1PRCFUO ;WISC/PL-850 UNDELIVERED ORDERS ;3/27/96 3:18 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;PRCFCT,PRCFAT,PRCFOT MUST BE SET IN MENU ACTION AND KILLED UPON EXIT
5CHECK S (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0 N I
6 S PRCFMULT=100-$P($G(^PRC(442,D0,5,1,0)),U,1)/100
7 S PRCFSHIP=$P($G(^PRC(442,D0,0)),U,13)
8 S PRCFSBOC=+$P($G(^PRC(442,D0,23)),U,1)
9 K PRCFLAG,PRCFP,ZBOC S (I,PRCFAFLG,PRCFSFLG)=0
10 F S I=$O(^PRC(442,D0,22,I)) Q:I'>0 D
11 . Q:'$D(^PRC(442,D0,22,I,0)) Q:+$P(^(0),U,1)=0
12 . S PRCFS=$P(^(0),U,1),PRCFO=$P(^(0),U,2)
13 . I $P(^(0),U,3)=991 S:'PRCFSBOC PRCFSBOC=PRCFS S:'PRCFSHIP PRCFSHIP=PRCFO
14 . S:'$D(ZBOC(PRCFS)) ZBOC(PRCFS)=0
15 . S ZBOC(PRCFS)=ZBOC(PRCFS)+PRCFO
16 . Q
17 I PRCFSBOC,+PRCFSHIP,+$G(ZBOC(PRCFSBOC))=+PRCFSHIP S PRCFSFLG=1
18 I $D(ZBOC) D ZBOC
19 I $D(PRCFLAG) S PRCFCT=PRCFCT+1,PRCFCS=PRCFCS+1
20 K PRCFA,PRCFA1,PRCFJ,PRCFII,PRCFS,PRCFSS,PRCFS1,PRCFO1,PRCFP,PRCFU
21 K PRCFTOT,PRCTDT,PRCFLAG,PRCFMULT,PRCFSBOC,PRCFSHIP,PRCFSFLG,PRCFAFLG
22 K ZBOC,I
23 Q
24ZBOC S PRCFS="" F S PRCFS=$O(ZBOC(PRCFS)) Q:PRCFS="" S PRCFO=ZBOC(PRCFS),PRCFU=PRCFO D A
25 I 'PRCFAFLG,PRCFSFLG S PRCFP(PRCFSBOC)=PRCFSHIP_"^0^"_PRCFSHIP
26 I PRCFAFLG,PRCFSFLG K PRCFP(PRCFSBOC)
27 S PRCFS="" F S PRCFS=$O(PRCFP(PRCFS)) Q:PRCFS="" D PRINT
28 Q
29A S (PRCFA1,PRCFJ)=0
30 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 AA
31 S PRCFA1=PRCFA1*PRCFMULT,PRCFU=PRCFO-PRCFA1
32 I PRCFU>.01,PRCFA1,PRCFSBOC=PRCFS S PRCFU=PRCFU-PRCFSHIP,PRCFA1=PRCFA1+PRCFSHIP,PRCFSHIP=0
33 I PRCFA1 S PRCFAFLG=1
34 I PRCFU>.01 S PRCFP(PRCFS)=PRCFO_U_PRCFA1_U_PRCFU
35 Q
36AA K PRCFTOT S PRCFII=0 F 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
37 Q
38PRINT I +PRCFS=0 K PRCFO,PRCFA1,PRCFU Q
39 S PRCFO=$P(PRCFP(PRCFS),U,1),PRCFA1=$P(PRCFP(PRCFS),U,2)
40 S PRCFU=$P(PRCFP(PRCFS),U,3)
41 S PRCFLAG(+PRCFU)=1,PRCFTOT(+PRCFS)=1,PRCFAT=PRCFAT+PRCFA1,PRCFAS=PRCFAS+PRCFA1,PRCFOS=PRCFOS+PRCFO
42 I $D(PRCFTOT) S PRCFOT=PRCFOT+PRCFO
43 W ?64,+PRCFS,?71,$J(PRCFO,12,2),?85,$J(PRCFA1,12,2),?100,$J(PRCFU,12,2),!
44 Q
45C S (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0 N I
46 S PRCFMULT=100-$P($G(^PRC(442,D0,5,1,0)),U,1)/100
47 S PRCFSHIP=$P($G(^PRC(442,D0,0)),U,13)
48 S PRCFSBOC=+$P($G(^PRC(442,D0,23)),U,1)
49 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,$P(^(0),U,3)'=991 S PRCFS=$P(^(0),U,1),PRCFO=$P(^(0),U,2) D
50 . S (PRCFA1,PRCFJ)=0
51 . 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
52 . . 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
53 . S PRCFA1=PRCFA1*PRCFMULT,PRCFU=PRCFO-PRCFA1
54 . I PRCFU>.01,PRCFA1,PRCFSBOC=PRCFS S PRCFU=PRCFU-PRCFSHIP
55 K PRCFLAG,PRCFTOT,PRCFMULT
56 Q
57B 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)
58 K PRCFAP,PRCFCAP,PRCFB,PRCFAS,PRCFOS,PRCFUS,PRCFCS,PRCFAT,PRCFCT,PRCFOT Q
59SUB I 'PRCFCT,$D(PRCFB) W !!,"850 UNDELIVERED ORDERS RECONCILIATION FOR STATION "_PRCFSITE_" FROM "_PRCFBEGX_" TO "_PRCFENDX,!!
60 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)
61 W:'$D(PRCFB) !!,?11,"APPROPRIATION: ",PRCFCAP S (PRCFCS,PRCFOS,PRCFAS)=0
62 Q
Note: See TracBrowser for help on using the repository browser.