- 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 Mar 13, 2025@21:15:16 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
