PRCHFPD1.m

PRCHFPD1 ;SF-ISC/KSS-FPDS REPORT FROM TEMPLATE W/0 FPDS DATA ;12-8-88/9:30 AM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 K ^TMP("CN",$J) S (PRCHJ,PRCHT,PRCHCT)=0

 F PRCHI=0:0 S PRCHJ=$O(^PRC(442,D0,9,PRCHJ)) Q:PRCHJ'>0  I $D(^(PRCHJ,0)) D S1

 S PRCHCN=0 F PRCHI=0:0 S PRCHCN=$O(^TMP("CN",$J,PRCHCN)) Q:PRCHCN=""  S PRCHCT=PRCHCT+1 W ?58,$S(PRCHCN="ZZZZ":"",1:PRCHCN),?73,$J(^TMP("CN",$J,PRCHCN),11,2),!

 W:PRCHCT>1 ?73,"-----------",!,?73,$J(PRCHT,11,2)

 K ^TMP("CN",$J),PRCHI,PRCHJ,PRCHCN,PRCHCT,PRCHAM,PRCHT,PRCHX

 Q

S1 S PRCHX=^PRC(442,D0,9,PRCHJ,0),PRCHAM=$P(PRCHX,U,1),PRCHCN=$S($P(PRCHX,U,3)'="":$P(PRCHX,U,3),1:"ZZZZ") S:'$D(^TMP("CN",$J,PRCHCN)) ^TMP("CN",$J,PRCHCN)=0 S ^TMP("CN",$J,PRCHCN)=^TMP("CN",$J,PRCHCN)+PRCHAM,PRCHT=PRCHT+PRCHAM

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHFPD1   815     printed  Apr 09, 2024@21:11:02                                                                                                                                                                                                     Page 2

PRCHFPD1  ;SF-ISC/KSS-FPDS REPORT FROM TEMPLATE W/0 FPDS DATA ;12-8-88/9:30 AM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2        KILL ^TMP("CN",$JOB)

           SET (PRCHJ,PRCHT,PRCHCT)=0

 +3        FOR PRCHI=0:0

               SET PRCHJ=$ORDER(^PRC(442,D0,9,PRCHJ))

               if PRCHJ'>0

                   QUIT 

               IF $DATA(^(PRCHJ,0))

                   DO S1

 +4        SET PRCHCN=0

           FOR PRCHI=0:0

               SET PRCHCN=$ORDER(^TMP("CN",$JOB,PRCHCN))

               if PRCHCN=""

                   QUIT 

               SET PRCHCT=PRCHCT+1

               WRITE ?58,$SELECT(PRCHCN="ZZZZ":"",1:PRCHCN),?73,$JUSTIFY(^TMP("CN",$JOB,PRCHCN),11,2),!

 +5        if PRCHCT>1

               WRITE ?73,"-----------",!,?73,$JUSTIFY(PRCHT,11,2)

 +6        KILL ^TMP("CN",$JOB),PRCHI,PRCHJ,PRCHCN,PRCHCT,PRCHAM,PRCHT,PRCHX

 +7        QUIT 

S1         SET PRCHX=^PRC(442,D0,9,PRCHJ,0)

           SET PRCHAM=$PIECE(PRCHX,U,1)

           SET PRCHCN=$SELECT($PIECE(PRCHX,U,3)'="":$PIECE(PRCHX,U,3),1:"ZZZZ")

           if '$DATA(^TMP("CN",$JOB,PRCHCN))

               SET ^TMP("CN",$JOB,PRCHCN)=0

           SET ^TMP("CN",$JOB,PRCHCN)=^TMP("CN",$JOB,PRCHCN)+PRCHAM

           SET PRCHT=PRCHT+PRCHAM

 +1        QUIT