- 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 ---[H[J[2J[HPRCHFPD1 815 printed Jan 18, 2025@03:08:43 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