- 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 Mar 13, 2025@21:09:15 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
