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

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