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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFUO 3693 printed Nov 22, 2024@17:14:34 Page 2
PRCFUO ;WISC/PL-850 UNDELIVERED ORDERS ;3/27/96 3:18 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;PRCFCT,PRCFAT,PRCFOT MUST BE SET IN MENU ACTION AND KILLED UPON EXIT
CHECK SET (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0
NEW I
+1 SET PRCFMULT=100-$PIECE($GET(^PRC(442,D0,5,1,0)),U,1)/100
+2 SET PRCFSHIP=$PIECE($GET(^PRC(442,D0,0)),U,13)
+3 SET PRCFSBOC=+$PIECE($GET(^PRC(442,D0,23)),U,1)
+4 KILL PRCFLAG,PRCFP,ZBOC
SET (I,PRCFAFLG,PRCFSFLG)=0
+5 FOR
SET I=$ORDER(^PRC(442,D0,22,I))
if I'>0
QUIT
Begin DoDot:1
+6 if '$DATA(^PRC(442,D0,22,I,0))
QUIT
if +$PIECE(^(0),U,1)=0
QUIT
+7 SET PRCFS=$PIECE(^(0),U,1)
SET PRCFO=$PIECE(^(0),U,2)
+8 IF $PIECE(^(0),U,3)=991
if 'PRCFSBOC
SET PRCFSBOC=PRCFS
if 'PRCFSHIP
SET PRCFSHIP=PRCFO
+9 if '$DATA(ZBOC(PRCFS))
SET ZBOC(PRCFS)=0
+10 SET ZBOC(PRCFS)=ZBOC(PRCFS)+PRCFO
+11 QUIT
End DoDot:1
+12 IF PRCFSBOC
IF +PRCFSHIP
IF +$GET(ZBOC(PRCFSBOC))=+PRCFSHIP
SET PRCFSFLG=1
+13 IF $DATA(ZBOC)
DO ZBOC
+14 IF $DATA(PRCFLAG)
SET PRCFCT=PRCFCT+1
SET PRCFCS=PRCFCS+1
+15 KILL PRCFA,PRCFA1,PRCFJ,PRCFII,PRCFS,PRCFSS,PRCFS1,PRCFO1,PRCFP,PRCFU
+16 KILL PRCFTOT,PRCTDT,PRCFLAG,PRCFMULT,PRCFSBOC,PRCFSHIP,PRCFSFLG,PRCFAFLG
+17 KILL ZBOC,I
+18 QUIT
ZBOC SET PRCFS=""
FOR
SET PRCFS=$ORDER(ZBOC(PRCFS))
if PRCFS=""
QUIT
SET PRCFO=ZBOC(PRCFS)
SET PRCFU=PRCFO
DO A
+1 IF 'PRCFAFLG
IF PRCFSFLG
SET PRCFP(PRCFSBOC)=PRCFSHIP_"^0^"_PRCFSHIP
+2 IF PRCFAFLG
IF PRCFSFLG
KILL PRCFP(PRCFSBOC)
+3 SET PRCFS=""
FOR
SET PRCFS=$ORDER(PRCFP(PRCFS))
if PRCFS=""
QUIT
DO PRINT
+4 QUIT
A SET (PRCFA1,PRCFJ)=0
+1 FOR
SET PRCFJ=$ORDER(^PRC(442,D0,2,PRCFJ))
if PRCFJ'>0
QUIT
IF $DATA(^(PRCFJ,0))
IF $PIECE(^PRC(442,D0,2,PRCFJ,0),U,4)'=""
SET PRCFSS=$PIECE(^(0),U,4)
IF +PRCFS=+PRCFSS
DO AA
+2 SET PRCFA1=PRCFA1*PRCFMULT
SET PRCFU=PRCFO-PRCFA1
+3 IF PRCFU>.01
IF PRCFA1
IF PRCFSBOC=PRCFS
SET PRCFU=PRCFU-PRCFSHIP
SET PRCFA1=PRCFA1+PRCFSHIP
SET PRCFSHIP=0
+4 IF PRCFA1
SET PRCFAFLG=1
+5 IF PRCFU>.01
SET PRCFP(PRCFS)=PRCFO_U_PRCFA1_U_PRCFU
+6 QUIT
AA KILL PRCFTOT
SET PRCFII=0
FOR
SET PRCFII=$ORDER(^PRC(442,D0,2,PRCFJ,3,PRCFII))
if PRCFII'>0
QUIT
IF $DATA(^(PRCFII,0))
IF $PIECE(^(0),U,3)
SET PRCFA=$PIECE(^(0),U,3)-$PIECE(^(0),U,5)
SET PRCFA1=PRCFA1+PRCFA
+1 QUIT
PRINT IF +PRCFS=0
KILL PRCFO,PRCFA1,PRCFU
QUIT
+1 SET PRCFO=$PIECE(PRCFP(PRCFS),U,1)
SET PRCFA1=$PIECE(PRCFP(PRCFS),U,2)
+2 SET PRCFU=$PIECE(PRCFP(PRCFS),U,3)
+3 SET PRCFLAG(+PRCFU)=1
SET PRCFTOT(+PRCFS)=1
SET PRCFAT=PRCFAT+PRCFA1
SET PRCFAS=PRCFAS+PRCFA1
SET PRCFOS=PRCFOS+PRCFO
+4 IF $DATA(PRCFTOT)
SET PRCFOT=PRCFOT+PRCFO
+5 WRITE ?64,+PRCFS,?71,$JUSTIFY(PRCFO,12,2),?85,$JUSTIFY(PRCFA1,12,2),?100,$JUSTIFY(PRCFU,12,2),!
+6 QUIT
C SET (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0
NEW I
+1 SET PRCFMULT=100-$PIECE($GET(^PRC(442,D0,5,1,0)),U,1)/100
+2 SET PRCFSHIP=$PIECE($GET(^PRC(442,D0,0)),U,13)
+3 SET PRCFSBOC=+$PIECE($GET(^PRC(442,D0,23)),U,1)
+4 KILL PRCFLAG
FOR I=0:0
SET I=$ORDER(^PRC(442,D0,22,I))
if PRCFU>.01!(I'>0)
QUIT
IF $DATA(^PRC(442,D0,22,I,0))
IF +$PIECE(^(0),U,1)'=0
IF $PIECE(^(0),U,3)'=991
SET PRCFS=$PIECE(^(0),U,1)
SET PRCFO=$PIECE(^(0),U,2)
Begin DoDot:1
+5 SET (PRCFA1,PRCFJ)=0
+6 FOR
SET PRCFJ=$ORDER(^PRC(442,D0,2,PRCFJ))
if PRCFJ'>0
QUIT
IF $DATA(^(PRCFJ,0))
IF $PIECE(^PRC(442,D0,2,PRCFJ,0),U,4)'=""
SET PRCFSS=$PIECE(^(0),U,4)
IF +PRCFS=+PRCFSS
Begin DoDot:2
+7 KILL PRCFTOT
FOR PRCFII=0:0
SET PRCFII=$ORDER(^PRC(442,D0,2,PRCFJ,3,PRCFII))
if PRCFII'>0
QUIT
IF $DATA(^(PRCFII,0))
IF $PIECE(^(0),U,3)
SET PRCFA=$PIECE(^(0),U,3)-$PIECE(^(0),U,5)
SET PRCFA1=PRCFA1+PRCFA
End DoDot:2
+8 SET PRCFA1=PRCFA1*PRCFMULT
SET PRCFU=PRCFO-PRCFA1
+9 IF PRCFU>.01
IF PRCFA1
IF PRCFSBOC=PRCFS
SET PRCFU=PRCFU-PRCFSHIP
End DoDot:1
+10 KILL PRCFLAG,PRCFTOT,PRCFMULT
+11 QUIT
B SET PRCFB=1
DO SUB
WRITE !!,?14,"TOTAL NUMBER RECORDS ",PRCFCT,?58,"TOTALS $",?71,$JUSTIFY(PRCFOT,12,2),?85,$JUSTIFY(PRCFAT,12,2),?100,$JUSTIFY(PRCFOT-PRCFAT,12,2)
+1 KILL PRCFAP,PRCFCAP,PRCFB,PRCFAS,PRCFOS,PRCFUS,PRCFCS,PRCFAT,PRCFCT,PRCFOT
QUIT
SUB IF 'PRCFCT
IF $DATA(PRCFB)
WRITE !!,"850 UNDELIVERED ORDERS RECONCILIATION FOR STATION "_PRCFSITE_" FROM "_PRCFBEGX_" TO "_PRCFENDX,!!
+1 SET PRCFUS=PRCFOS-PRCFAS
WRITE ?71,"------------",?85,"------------",?100,"------------",!,?20,"NUMBER RECORDS ",PRCFCS,?55,"SUBTOTALS $",?71,$JUSTIFY(PRCFOS,12,2),?85,$JUSTIFY(PRCFAS,12,2),?100,$JUSTIFY(PRCFUS,12,2)
+2 if '$DATA(PRCFB)
WRITE !!,?11,"APPROPRIATION: ",PRCFCAP
SET (PRCFCS,PRCFOS,PRCFAS)=0
+3 QUIT
