source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFUO.m@ 1154

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