63 lines
3.5 KiB
Mathematica
63 lines
3.5 KiB
Mathematica
PRCFUO ;WISC/PL-850 UNDELIVERED ORDERS ;3/27/96 3:18 PM
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;PRCFCT,PRCFAT,PRCFOT MUST BE SET IN MENU ACTION AND KILLED UPON EXIT
|
|
CHECK 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,PRCFP,ZBOC S (I,PRCFAFLG,PRCFSFLG)=0
|
|
F S I=$O(^PRC(442,D0,22,I)) Q:I'>0 D
|
|
. Q:'$D(^PRC(442,D0,22,I,0)) Q:+$P(^(0),U,1)=0
|
|
. S PRCFS=$P(^(0),U,1),PRCFO=$P(^(0),U,2)
|
|
. I $P(^(0),U,3)=991 S:'PRCFSBOC PRCFSBOC=PRCFS S:'PRCFSHIP PRCFSHIP=PRCFO
|
|
. S:'$D(ZBOC(PRCFS)) ZBOC(PRCFS)=0
|
|
. S ZBOC(PRCFS)=ZBOC(PRCFS)+PRCFO
|
|
. Q
|
|
I PRCFSBOC,+PRCFSHIP,+$G(ZBOC(PRCFSBOC))=+PRCFSHIP S PRCFSFLG=1
|
|
I $D(ZBOC) D ZBOC
|
|
I $D(PRCFLAG) S PRCFCT=PRCFCT+1,PRCFCS=PRCFCS+1
|
|
K PRCFA,PRCFA1,PRCFJ,PRCFII,PRCFS,PRCFSS,PRCFS1,PRCFO1,PRCFP,PRCFU
|
|
K PRCFTOT,PRCTDT,PRCFLAG,PRCFMULT,PRCFSBOC,PRCFSHIP,PRCFSFLG,PRCFAFLG
|
|
K ZBOC,I
|
|
Q
|
|
ZBOC S PRCFS="" F S PRCFS=$O(ZBOC(PRCFS)) Q:PRCFS="" S PRCFO=ZBOC(PRCFS),PRCFU=PRCFO D A
|
|
I 'PRCFAFLG,PRCFSFLG S PRCFP(PRCFSBOC)=PRCFSHIP_"^0^"_PRCFSHIP
|
|
I PRCFAFLG,PRCFSFLG K PRCFP(PRCFSBOC)
|
|
S PRCFS="" F S PRCFS=$O(PRCFP(PRCFS)) Q:PRCFS="" D PRINT
|
|
Q
|
|
A 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 AA
|
|
S PRCFA1=PRCFA1*PRCFMULT,PRCFU=PRCFO-PRCFA1
|
|
I PRCFU>.01,PRCFA1,PRCFSBOC=PRCFS S PRCFU=PRCFU-PRCFSHIP,PRCFA1=PRCFA1+PRCFSHIP,PRCFSHIP=0
|
|
I PRCFA1 S PRCFAFLG=1
|
|
I PRCFU>.01 S PRCFP(PRCFS)=PRCFO_U_PRCFA1_U_PRCFU
|
|
Q
|
|
AA 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
|
|
Q
|
|
PRINT I +PRCFS=0 K PRCFO,PRCFA1,PRCFU Q
|
|
S PRCFO=$P(PRCFP(PRCFS),U,1),PRCFA1=$P(PRCFP(PRCFS),U,2)
|
|
S PRCFU=$P(PRCFP(PRCFS),U,3)
|
|
S PRCFLAG(+PRCFU)=1,PRCFTOT(+PRCFS)=1,PRCFAT=PRCFAT+PRCFA1,PRCFAS=PRCFAS+PRCFA1,PRCFOS=PRCFOS+PRCFO
|
|
I $D(PRCFTOT) S PRCFOT=PRCFOT+PRCFO
|
|
W ?64,+PRCFS,?71,$J(PRCFO,12,2),?85,$J(PRCFA1,12,2),?100,$J(PRCFU,12,2),!
|
|
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,$P(^(0),U,3)'=991 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
|
|
K PRCFLAG,PRCFTOT,PRCFMULT
|
|
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,$D(PRCFB) W !!,"850 UNDELIVERED ORDERS RECONCILIATION FOR STATION "_PRCFSITE_" FROM "_PRCFBEGX_" TO "_PRCFENDX,!!
|
|
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
|