PRCHRPT2 ;SF/TKW-PRINT 1988 FPDS REPORTS ; 6/17/97 9:30 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;****NOTE: ALL OPTIONS EXCEPT EN5 ARE NO LONGER IN USE. ****
;
EN1 Q S PRCHRPT=1,PRCHH1="FPDS LESS THAN 10K" G RANGE
;
EN2 Q S PRCHRPT=2,PRCHH1="FPDS GREATER THAN 10K" G RANGE
;
EN3 Q S PRCHRPT=3,PRCHH1="FPDS BY CONTRACT NO." G RANGE
;
EN4 Q S PRCHRPT=4,PRCHH1="FPDS LINE-ITEM COUNT" G RANGE
;
EN5 S PRCHRPT=5,PRCHH1="FUND CONTROL POINT" S PRCF("X")="SP" D ^PRCFSITE G RANGE
;
RANGE Q:'$D(PRC("SITE")) W !!!,"PRINT REPORT OF "_PRCHH1
S M="P.O.DATE",PRCHD="DATE" D RNG^PRCHRPT1 G:(FR["^")!(TO["^") EXIT I (FR["?")!(TO["?") D DSP G RANGE
;
RANG2 K PRCHD I PRCHRPT=5 S PRCHSFR=FR,PRCHSTO=TO,M="FUND CONTROL POINT" D RNG^PRCHRPT1 G:(FR["^")!(TO["^") EXIT I (FR["?")!(TO["?") D DSP2 G RANG2
I PRCHRPT=5 S PRCHFR=FR,PRCHTO=TO,FR=PRCHSFR,TO=PRCHSTO K PRCHSFR,PRCHSTO
S ZTRTN="ENP^PRCHRPT2" D SDEV^PRCHRPT1 G:POP EXIT G:'$D(IO(0)) EXIT G:IO(0)=IO EXIT
S M="print this report" D PDT^PRCHRPT1 G:X["^" EXIT
S ZTDTH=PRCHPDAT,ZTDESC="Print "_PRCHH1
K ZTSAVE S ZTSAVE("U")="",ZTSAVE("PRCHRPT")="",ZTSAVE("FR")="",ZTSAVE("TO")="",ZTSAVE("PRCHH1")="",ZTSAVE("PRC(""SITE"")")=""
I PRCHRPT=5 S ZTSAVE("PRCHFR")="",ZTSAVE("PRCHTO")=""
D ^%ZTLOAD K ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTSK,ZTSKT G EXIT
;
DSP W !! W:FR["?" "TO SORT IN SEQUENCE , STARTING FROM A CERTAIN "_M_"," W:TO["?" "TO SORT ONLY UP TO A CERTAIN "_M_","
W !,"TYPE THAT "_M,!,"'@' MEANS 'INCLUDE NULL "_M_" FIELDS'" Q
;
DSP2 S DIC="^PRC(420,"_PRC("SITE")_",1,",DA(1)=PRC("SITE"),DIC(0)="QEMNZ",X="?" D ^DIC Q
;
ENP ; ENTRY POINT FOR PRINTING FPDS REPORTS
D NOW^%DTC S Y=% D DD^%DT K ^TMP($J) S PRCHPDAT=Y
S PRCHPFR="FIRST DATE",PRCHPTO="LAST DATE" I +FR=FR S Y=FR D DD^%DT S PRCHPFR=Y
I +TO=TO S Y=TO D DD^%DT S PRCHPTO=Y
S PRCHPOR=0 D RD^PRCHRPT4,EN^PRCHRPT3
W $C(13) D:$D(ZTSK) KILL^%ZTLOAD K ZTSK,ZTSKT
G EXIT
;
EXIT K %,%DT,%H,%ZIS,IO("Q"),IOP,I,J,K,M,N,DA,DIC,X,Y,ZTRTN,FR,TO,^TMP($J),PRCHH1,PRCHRPT,PRCHPFR,PRCHPTO
K PRCHAMT,PRCHBOU2,PRCHBOUT,PRCHCON,PRCHDY,PRCHET,PRCHFR,PRCHH1,PRCHKEY,PRCHPAGE,PRCHFR
K PRCHPONO,PRCHPOR,PRCHTO,PRCHRFLG,PRCHRPT,PRCHSFR,PRCHSPN,PRCHSTO,PRCHTO,PRCHTOT,PRCHTOTA,PRCHTOTL,PRCHTYP,PRCHTYPP,PRCHX,PRCHD,PRCHPDAT,PRCHPOD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT2 2337 printed Sep 23, 2025@19:46:34 Page 2
PRCHRPT2 ;SF/TKW-PRINT 1988 FPDS REPORTS ; 6/17/97 9:30 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;****NOTE: ALL OPTIONS EXCEPT EN5 ARE NO LONGER IN USE. ****
+3 ;
EN1 QUIT
SET PRCHRPT=1
SET PRCHH1="FPDS LESS THAN 10K"
GOTO RANGE
+1 ;
EN2 QUIT
SET PRCHRPT=2
SET PRCHH1="FPDS GREATER THAN 10K"
GOTO RANGE
+1 ;
EN3 QUIT
SET PRCHRPT=3
SET PRCHH1="FPDS BY CONTRACT NO."
GOTO RANGE
+1 ;
EN4 QUIT
SET PRCHRPT=4
SET PRCHH1="FPDS LINE-ITEM COUNT"
GOTO RANGE
+1 ;
EN5 SET PRCHRPT=5
SET PRCHH1="FUND CONTROL POINT"
SET PRCF("X")="SP"
DO ^PRCFSITE
GOTO RANGE
+1 ;
RANGE if '$DATA(PRC("SITE"))
QUIT
WRITE !!!,"PRINT REPORT OF "_PRCHH1
+1 SET M="P.O.DATE"
SET PRCHD="DATE"
DO RNG^PRCHRPT1
if (FR["^")!(TO["^")
GOTO EXIT
IF (FR["?")!(TO["?")
DO DSP
GOTO RANGE
+2 ;
RANG2 KILL PRCHD
IF PRCHRPT=5
SET PRCHSFR=FR
SET PRCHSTO=TO
SET M="FUND CONTROL POINT"
DO RNG^PRCHRPT1
if (FR["^")!(TO["^")
GOTO EXIT
IF (FR["?")!(TO["?")
DO DSP2
GOTO RANG2
+1 IF PRCHRPT=5
SET PRCHFR=FR
SET PRCHTO=TO
SET FR=PRCHSFR
SET TO=PRCHSTO
KILL PRCHSFR,PRCHSTO
+2 SET ZTRTN="ENP^PRCHRPT2"
DO SDEV^PRCHRPT1
if POP
GOTO EXIT
if '$DATA(IO(0))
GOTO EXIT
if IO(0)=IO
GOTO EXIT
+3 SET M="print this report"
DO PDT^PRCHRPT1
if X["^"
GOTO EXIT
+4 SET ZTDTH=PRCHPDAT
SET ZTDESC="Print "_PRCHH1
+5 KILL ZTSAVE
SET ZTSAVE("U")=""
SET ZTSAVE("PRCHRPT")=""
SET ZTSAVE("FR")=""
SET ZTSAVE("TO")=""
SET ZTSAVE("PRCHH1")=""
SET ZTSAVE("PRC(""SITE"")")=""
+6 IF PRCHRPT=5
SET ZTSAVE("PRCHFR")=""
SET ZTSAVE("PRCHTO")=""
+7 DO ^%ZTLOAD
KILL ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTSK,ZTSKT
GOTO EXIT
+8 ;
DSP WRITE !!
if FR["?"
WRITE "TO SORT IN SEQUENCE , STARTING FROM A CERTAIN "_M_","
if TO["?"
WRITE "TO SORT ONLY UP TO A CERTAIN "_M_","
+1 WRITE !,"TYPE THAT "_M,!,"'@' MEANS 'INCLUDE NULL "_M_" FIELDS'"
QUIT
+2 ;
DSP2 SET DIC="^PRC(420,"_PRC("SITE")_",1,"
SET DA(1)=PRC("SITE")
SET DIC(0)="QEMNZ"
SET X="?"
DO ^DIC
QUIT
+1 ;
ENP ; ENTRY POINT FOR PRINTING FPDS REPORTS
+1 DO NOW^%DTC
SET Y=%
DO DD^%DT
KILL ^TMP($JOB)
SET PRCHPDAT=Y
+2 SET PRCHPFR="FIRST DATE"
SET PRCHPTO="LAST DATE"
IF +FR=FR
SET Y=FR
DO DD^%DT
SET PRCHPFR=Y
+3 IF +TO=TO
SET Y=TO
DO DD^%DT
SET PRCHPTO=Y
+4 SET PRCHPOR=0
DO RD^PRCHRPT4
DO EN^PRCHRPT3
+5 WRITE $CHAR(13)
if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK,ZTSKT
+6 GOTO EXIT
+7 ;
EXIT KILL %,%DT,%H,%ZIS,IO("Q"),IOP,I,J,K,M,N,DA,DIC,X,Y,ZTRTN,FR,TO,^TMP($JOB),PRCHH1,PRCHRPT,PRCHPFR,PRCHPTO
+1 KILL PRCHAMT,PRCHBOU2,PRCHBOUT,PRCHCON,PRCHDY,PRCHET,PRCHFR,PRCHH1,PRCHKEY,PRCHPAGE,PRCHFR
+2 KILL PRCHPONO,PRCHPOR,PRCHTO,PRCHRFLG,PRCHRPT,PRCHSFR,PRCHSPN,PRCHSTO,PRCHTO,PRCHTOT,PRCHTOTA,PRCHTOTL,PRCHTYP,PRCHTYPP,PRCHX,PRCHD,PRCHPDAT,PRCHPOD
+3 QUIT
