PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
V ;;5.1;IFCAP;**106**;Oct 20, 2000
;Per VHA Directive 2004-038, this routine should not be modified.
S (PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT)=0,L=0
S DIC="^PRC(442,",DHD="850 UNDELIVERED ORDERS FOR MANDATED SOURCES"
S FLDS="[PRCFUOMS]",BY="[PRCFUOMS]",DIOEND="D B^PRCFUOMS"
S DIS(0)="I $D(^PRC(442,D0,0)),$O(^PRC(442,D0,22,0))>0 I $P(^PRC(442,D0,0),U,17)'=$P(^(0),U,16)"
S PRCFI=";30;31;33;37;38;40;41;45;48;49;"
S DIS(1)="I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"") D C^PRCFUOMS I PRCFU>.01"
D EN1^DIP
EXIT K PRCFS,PRCFS1,PRCFO,PRCFO1,PRCFC,PRCFA,PRCFA1,PRCFI,PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT,PRCFTOT,PRCFII,PRCFLAG,PRCFSS,PRCFU,PRCTDT,PRCFAP,ZBOC
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 W !!
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
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 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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFUOMS 2109 printed Dec 13, 2024@02:04:30 Page 2
PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
V ;;5.1;IFCAP;**106**;Oct 20, 2000
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 SET (PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT)=0
SET L=0
+3 SET DIC="^PRC(442,"
SET DHD="850 UNDELIVERED ORDERS FOR MANDATED SOURCES"
+4 SET FLDS="[PRCFUOMS]"
SET BY="[PRCFUOMS]"
SET DIOEND="D B^PRCFUOMS"
+5 SET DIS(0)="I $D(^PRC(442,D0,0)),$O(^PRC(442,D0,22,0))>0 I $P(^PRC(442,D0,0),U,17)'=$P(^(0),U,16)"
+6 SET PRCFI=";30;31;33;37;38;40;41;45;48;49;"
+7 SET DIS(1)="I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"") D C^PRCFUOMS I PRCFU>.01"
+8 DO EN1^DIP
EXIT KILL PRCFS,PRCFS1,PRCFO,PRCFO1,PRCFC,PRCFA,PRCFA1,PRCFI,PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT,PRCFTOT,PRCFII,PRCFLAG,PRCFSS,PRCFU,PRCTDT,PRCFAP,ZBOC
+1 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
WRITE !!
+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
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
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 QUIT
