Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCFUOMS

PRCFUOMS.m

Go to the documentation of this file.
  1. PRCFUOMS ;WISC/PL-850 UNDELIVERED ORDERS FOR MANDATED SOURCE ; 8/22/96 1:38 PM
  1. V ;;5.1;IFCAP;**106**;Oct 20, 2000
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. S (PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT)=0,L=0
  1. S DIC="^PRC(442,",DHD="850 UNDELIVERED ORDERS FOR MANDATED SOURCES"
  1. S FLDS="[PRCFUOMS]",BY="[PRCFUOMS]",DIOEND="D B^PRCFUOMS"
  1. 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)"
  1. S PRCFI=";30;31;33;37;38;40;41;45;48;49;"
  1. S DIS(1)="I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"") D C^PRCFUOMS I PRCFU>.01"
  1. D EN1^DIP
  1. EXIT K PRCFS,PRCFS1,PRCFO,PRCFO1,PRCFC,PRCFA,PRCFA1,PRCFI,PRCFAS,PRCFCS,PRCFOS,PRCFAT,PRCFCT,PRCFOT,PRCFTOT,PRCFII,PRCFLAG,PRCFSS,PRCFU,PRCTDT,PRCFAP,ZBOC
  1. Q
  1. 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)
  1. K PRCFAP,PRCFCAP,PRCFB,PRCFAS,PRCFOS,PRCFUS,PRCFCS,PRCFAT,PRCFCT,PRCFOT Q
  1. SUB I 'PRCFCT W !!
  1. 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)
  1. W:'$D(PRCFB) !!,?11,"APPROPRIATION: ",PRCFCAP S (PRCFCS,PRCFOS,PRCFAS)=0
  1. Q
  1. C S (PRCFO,PRCFS,PRCFSS,PRCFA,PRCFA1,PRCFU)=0 N I
  1. S PRCFMULT=100-$P($G(^PRC(442,D0,5,1,0)),U,1)/100
  1. S PRCFSHIP=$P($G(^PRC(442,D0,0)),U,13)
  1. S PRCFSBOC=+$P($G(^PRC(442,D0,23)),U,1)
  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
  1. . S (PRCFA1,PRCFJ)=0
  1. . 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
  1. . . 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
  1. . S PRCFA1=PRCFA1*PRCFMULT,PRCFU=PRCFO-PRCFA1
  1. . I PRCFU>.01,PRCFA1,PRCFSBOC=PRCFS S PRCFU=PRCFU-PRCFSHIP
  1. Q