- PRCHFPD ;SF-ISC/KSS,WISC/RWS,SC-NEW FPDS REPORT <25K ;7-10-89/2:30 PM
- V ;;5.1;IFCAP;**16**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- FPD S %DT("A")="START WITH P.O. DATE: ",%DT="AE" D ^%DT
- I Y'>0 K %DT,Y Q
- S PRCHF=Y,%DT("A")="GO TO P.O. DATE: "
- ;
- F1 D ^%DT G FPD:Y'>0 I PRCHF>Y W !,"Last date cannot be prior to first date." G FPD
- S PRCHT=Y D DD^%DT S PRCHPT=Y S Y=PRCHF D DD^%DT S PRCHPF=Y
- G F2
- ;
- INIT S PRCHN=0 K ^TMP("CN",$J)
- F PRCHO=0:0 S PRCHN=$O(^PRCD(420.6,"B",PRCHN)) Q:PRCHN="" S (^TMP("CN",$J,PRCHN),^TMP("CN",$J,PRCHN,"A"))=0
- Q
- ;
- F2 K %DT,PRCHN,PRCHO
- S DHD="[PRCH FPDS <25K HEADER]",DIOBEG="D INIT^PRCHFPD",L=0,FLDS="[PRCH FPDS <25K PRINT]",BY="[PRCH FPDS <25K]",FR=PRCHF_","_PRC("SITE")_"-,9,0",TO=PRCHT_","_PRC("SITE")_"z,,25000",DIC="^PRC(442,",DIOEND="D P^PRCHFPD" D EN1^DIP
- ;
- FEND K ^TMP("CN",$J),^TMP("TOT",$J),PRCHF,PRCHI,PRCHG,PRCHN,PRCHP,PRCHPF,PRCHPT,PRCHQ,PRCHS,PRCHT,PRCHTN,PTCHTA,PRCHV,PRCHY
- ;
- K K DIC,DHD,L,FLDS,BY,FR,TO
- Q
- ;
- P ;PRINT TOTALS FROM 'DIOEND' VARIABLE WITH PRINT TEMPLATE
- F PRCHP="A","B","C","D","E","X","Y","Z" S ^TMP("TOT",$J,PRCHP)=0
- S PRCHS=" $ # P.O. ",$P(PRCHG,"-",20)="- "
- W !,"TOTALS:",!,?1,PRCHS,PRCHS,PRCHS,PRCHS,PRCHS,"(T)OTAL $ # P.O."
- S (PRCHTN,PRCHTA)=0 F PRCHN=1:1:4 S ^TMP("CN",$J,"T"_PRCHN)=0,^TMP("CN",$J,"T"_PRCHN,"A")=0
- F PRCHN=1:1:4 W !,?1 F PRCHP="A","B","C","D","E" D P3 D:PRCHP="E" P5
- W !,?1,PRCHG,PRCHG,PRCHG,PRCHG,PRCHG,PRCHG
- W:IOST="C-" ?1
- W:IOST'="C-" !,?1
- F PRCHP="A","B","C","D","E" W "TOT NO.("_PRCHP_") ",$J(^TMP("TOT",$J,PRCHP),9)," "
- W "A-E",$J(PRCHTA,11,2)," ",$J(PRCHTN,5)
- W !!,?22,PRCHS,PRCHS,PRCHS,"(T)OTAL $ # P.O."
- S (PRCHTN,PRCHTA)=0 F PRCHN=1:1:4 S ^TMP("CN",$J,"T"_PRCHN)=0,^TMP("CN",$J,"T"_PRCHN,"A")=0
- F PRCHN=1:1:4 W !,?22 F PRCHP="X","Y","Z" D P3 D:PRCHP="Z" P5
- W !,?22,PRCHG,PRCHG,PRCHG,PRCHG,!,?22 F PRCHP="X","Y","Z" W "TOT NO.("_PRCHP_") ",$J(^TMP("TOT",$J,PRCHP),9)," "
- W "X-Z",$J(PRCHTA,11,2)," ",$J(PRCHTN,5)
- S L="L" I ^TMP("CN",$J,"L")'=0 S ^("K")=^("K")+^("L"),L=^("L","A"),^("A")=^TMP("CN",$J,"K","A")+L,L=""
- ;'I' category is being changed to 'T1' as per FPDS
- ;W !!,?22,PRCHS,PRCHS,PRCHS,PRCHS,!,?22 F PRCHP="I",L,"N","S" D P4
- W !!,?22,PRCHS,PRCHS,PRCHS,PRCHS,!,?22 F PRCHP="T1",L,"N","LV" D P4
- W !,?22 F PRCHP="J","M","P","U" D P4
- ;Removing Category K & leaving the format of report as is, at a later time we might re-use the position for future categories per FPDS --- SC
- ;W !,?22 F PRCHP="K","O","Q","W" D P4
- W !,?22 F PRCHP="","HP","O","W" D P4
- W !,?22 F PRCHP="","HZ","RV","LW" D P4
- W !,?22 F PRCHP="","","S","OO" D P4
- ;
- PEND W @IOF Q
- ;
- P3 S PRCHV=PRCHP_PRCHN,^TMP("TOT",$J,PRCHP)=^TMP("TOT",$J,PRCHP)+^TMP("CN",$J,PRCHV)
- S ^TMP("CN",$J,"T"_PRCHN)=^TMP("CN",$J,"T"_PRCHN)+^TMP("CN",$J,PRCHV),^TMP("CN",$J,"T"_PRCHN,"A")=^TMP("CN",$J,"T"_PRCHN,"A")+^TMP("CN",$J,PRCHV,"A")
- W PRCHV," ",$J(^TMP("CN",$J,PRCHV,"A"),11,2)," ",$J(^TMP("CN",$J,PRCHV),5)," "
- Q
- ;
- P4 I PRCHP="" W " " Q ;BLANK ANY CATEGORY WHERE CODE IS NULL
- W $J(PRCHP,2)," ",$J(^TMP("CN",$J,PRCHP,"A"),11,2)," ",$J(^TMP("CN",$J,PRCHP),5)," "
- Q
- ;
- P5 W "T"_PRCHN," ",$J(^TMP("CN",$J,"T"_PRCHN,"A"),11,2)," ",$J(^TMP("CN",$J,"T"_PRCHN),5) S PRCHTN=PRCHTN+^TMP("CN",$J,"T"_PRCHN),PRCHTA=PRCHTA+^TMP("CN",$J,"T"_PRCHN,"A")
- Q
- ;
- CALC ;LOOP THRU AMOUNTS IN TEMPLATE (442)
- S PRCHJ=0 F PRCHO=0:0 S PRCHJ=$O(^PRC(442,D0,9,PRCHJ)) Q:PRCHJ'>0 I $D(^(PRCHJ,0)) S PRCHX=^(0) D C1
- K PRCHA,PRCHC,PRCHJ,PRCHK,PRCHL,PRCHO,PRCHX,PRCHY
- ;
- CEND Q
- ;
- C1 ;LOOP THRU CODES AND ADD TO ^TMP("CN",$J,ARRAY)
- F PRCHK=2,4,5 S PRCHY=$P(PRCHX,U,PRCHK) D C2:PRCHY
- ;LOOP THRU BREAKOUT CODES AND ADD TO ^TMP("CN",$J,ARRAY)
- S PRCHL=0 F PRCHO=0:0 S PRCHL=$O(^PRC(442,D0,9,PRCHJ,1,PRCHL)) Q:PRCHL'>0 I $D(^(PRCHL,0)) S PRCHY=$P(^(0),U,1) D C2:PRCHY
- Q
- ;
- C2 Q:'$D(^PRCD(420.6,PRCHY,0))
- S PRCHC=$P(^PRCD(420.6,PRCHY,0),U,1),^TMP("CN",$J,PRCHC)=^TMP("CN",$J,PRCHC)+1,PRCHA=$P(PRCHX,U,1),^TMP("CN",$J,PRCHC,"A")=^TMP("CN",$J,PRCHC,"A")+PRCHA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPD 4089 printed Feb 18, 2025@23:33:53 Page 2
- PRCHFPD ;SF-ISC/KSS,WISC/RWS,SC-NEW FPDS REPORT <25K ;7-10-89/2:30 PM
- V ;;5.1;IFCAP;**16**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- FPD SET %DT("A")="START WITH P.O. DATE: "
- SET %DT="AE"
- DO ^%DT
- +1 IF Y'>0
- KILL %DT,Y
- QUIT
- +2 SET PRCHF=Y
- SET %DT("A")="GO TO P.O. DATE: "
- +3 ;
- F1 DO ^%DT
- if Y'>0
- GOTO FPD
- IF PRCHF>Y
- WRITE !,"Last date cannot be prior to first date."
- GOTO FPD
- +1 SET PRCHT=Y
- DO DD^%DT
- SET PRCHPT=Y
- SET Y=PRCHF
- DO DD^%DT
- SET PRCHPF=Y
- +2 GOTO F2
- +3 ;
- INIT SET PRCHN=0
- KILL ^TMP("CN",$JOB)
- +1 FOR PRCHO=0:0
- SET PRCHN=$ORDER(^PRCD(420.6,"B",PRCHN))
- if PRCHN=""
- QUIT
- SET (^TMP("CN",$JOB,PRCHN),^TMP("CN",$JOB,PRCHN,"A"))=0
- +2 QUIT
- +3 ;
- F2 KILL %DT,PRCHN,PRCHO
- +1 SET DHD="[PRCH FPDS <25K HEADER]"
- SET DIOBEG="D INIT^PRCHFPD"
- SET L=0
- SET FLDS="[PRCH FPDS <25K PRINT]"
- SET BY="[PRCH FPDS <25K]"
- SET FR=PRCHF_","_PRC("SITE")_"-,9,0"
- SET TO=PRCHT_","_PRC("SITE")_"z,,25000"
- SET DIC="^PRC(442,"
- SET DIOEND="D P^PRCHFPD"
- DO EN1^DIP
- +2 ;
- FEND KILL ^TMP("CN",$JOB),^TMP("TOT",$JOB),PRCHF,PRCHI,PRCHG,PRCHN,PRCHP,PRCHPF,PRCHPT,PRCHQ,PRCHS,PRCHT,PRCHTN,PTCHTA,PRCHV,PRCHY
- +1 ;
- K KILL DIC,DHD,L,FLDS,BY,FR,TO
- +1 QUIT
- +2 ;
- P ;PRINT TOTALS FROM 'DIOEND' VARIABLE WITH PRINT TEMPLATE
- +1 FOR PRCHP="A","B","C","D","E","X","Y","Z"
- SET ^TMP("TOT",$JOB,PRCHP)=0
- +2 SET PRCHS=" $ # P.O. "
- SET $PIECE(PRCHG,"-",20)="- "
- +3 WRITE !,"TOTALS:",!,?1,PRCHS,PRCHS,PRCHS,PRCHS,PRCHS,"(T)OTAL $ # P.O."
- +4 SET (PRCHTN,PRCHTA)=0
- FOR PRCHN=1:1:4
- SET ^TMP("CN",$JOB,"T"_PRCHN)=0
- SET ^TMP("CN",$JOB,"T"_PRCHN,"A")=0
- +5 FOR PRCHN=1:1:4
- WRITE !,?1
- FOR PRCHP="A","B","C","D","E"
- DO P3
- if PRCHP="E"
- DO P5
- +6 WRITE !,?1,PRCHG,PRCHG,PRCHG,PRCHG,PRCHG,PRCHG
- +7 if IOST="C-"
- WRITE ?1
- +8 if IOST'="C-"
- WRITE !,?1
- +9 FOR PRCHP="A","B","C","D","E"
- WRITE "TOT NO.("_PRCHP_") ",$JUSTIFY(^TMP("TOT",$JOB,PRCHP),9)," "
- +10 WRITE "A-E",$JUSTIFY(PRCHTA,11,2)," ",$JUSTIFY(PRCHTN,5)
- +11 WRITE !!,?22,PRCHS,PRCHS,PRCHS,"(T)OTAL $ # P.O."
- +12 SET (PRCHTN,PRCHTA)=0
- FOR PRCHN=1:1:4
- SET ^TMP("CN",$JOB,"T"_PRCHN)=0
- SET ^TMP("CN",$JOB,"T"_PRCHN,"A")=0
- +13 FOR PRCHN=1:1:4
- WRITE !,?22
- FOR PRCHP="X","Y","Z"
- DO P3
- if PRCHP="Z"
- DO P5
- +14 WRITE !,?22,PRCHG,PRCHG,PRCHG,PRCHG,!,?22
- FOR PRCHP="X","Y","Z"
- WRITE "TOT NO.("_PRCHP_") ",$JUSTIFY(^TMP("TOT",$JOB,PRCHP),9)," "
- +15 WRITE "X-Z",$JUSTIFY(PRCHTA,11,2)," ",$JUSTIFY(PRCHTN,5)
- +16 SET L="L"
- IF ^TMP("CN",$JOB,"L")'=0
- SET ^("K")=^("K")+^("L")
- SET L=^("L","A")
- SET ^("A")=^TMP("CN",$JOB,"K","A")+L
- SET L=""
- +17 ;'I' category is being changed to 'T1' as per FPDS
- +18 ;W !!,?22,PRCHS,PRCHS,PRCHS,PRCHS,!,?22 F PRCHP="I",L,"N","S" D P4
- +19 WRITE !!,?22,PRCHS,PRCHS,PRCHS,PRCHS,!,?22
- FOR PRCHP="T1",L,"N","LV"
- DO P4
- +20 WRITE !,?22
- FOR PRCHP="J","M","P","U"
- DO P4
- +21 ;Removing Category K & leaving the format of report as is, at a later time we might re-use the position for future categories per FPDS --- SC
- +22 ;W !,?22 F PRCHP="K","O","Q","W" D P4
- +23 WRITE !,?22
- FOR PRCHP="","HP","O","W"
- DO P4
- +24 WRITE !,?22
- FOR PRCHP="","HZ","RV","LW"
- DO P4
- +25 WRITE !,?22
- FOR PRCHP="","","S","OO"
- DO P4
- +26 ;
- PEND WRITE @IOF
- QUIT
- +1 ;
- P3 SET PRCHV=PRCHP_PRCHN
- SET ^TMP("TOT",$JOB,PRCHP)=^TMP("TOT",$JOB,PRCHP)+^TMP("CN",$JOB,PRCHV)
- +1 SET ^TMP("CN",$JOB,"T"_PRCHN)=^TMP("CN",$JOB,"T"_PRCHN)+^TMP("CN",$JOB,PRCHV)
- SET ^TMP("CN",$JOB,"T"_PRCHN,"A")=^TMP("CN",$JOB,"T"_PRCHN,"A")+^TMP("CN",$JOB,PRCHV,"A")
- +2 WRITE PRCHV," ",$JUSTIFY(^TMP("CN",$JOB,PRCHV,"A"),11,2)," ",$JUSTIFY(^TMP("CN",$JOB,PRCHV),5)," "
- +3 QUIT
- +4 ;
- P4 ;BLANK ANY CATEGORY WHERE CODE IS NULL
- IF PRCHP=""
- WRITE " "
- QUIT
- +1 WRITE $JUSTIFY(PRCHP,2)," ",$JUSTIFY(^TMP("CN",$JOB,PRCHP,"A"),11,2)," ",$JUSTIFY(^TMP("CN",$JOB,PRCHP),5)," "
- +2 QUIT
- +3 ;
- P5 WRITE "T"_PRCHN," ",$JUSTIFY(^TMP("CN",$JOB,"T"_PRCHN,"A"),11,2)," ",$JUSTIFY(^TMP("CN",$JOB,"T"_PRCHN),5)
- SET PRCHTN=PRCHTN+^TMP("CN",$JOB,"T"_PRCHN)
- SET PRCHTA=PRCHTA+^TMP("CN",$JOB,"T"_PRCHN,"A")
- +1 QUIT
- +2 ;
- CALC ;LOOP THRU AMOUNTS IN TEMPLATE (442)
- +1 SET PRCHJ=0
- FOR PRCHO=0:0
- SET PRCHJ=$ORDER(^PRC(442,D0,9,PRCHJ))
- if PRCHJ'>0
- QUIT
- IF $DATA(^(PRCHJ,0))
- SET PRCHX=^(0)
- DO C1
- +2 KILL PRCHA,PRCHC,PRCHJ,PRCHK,PRCHL,PRCHO,PRCHX,PRCHY
- +3 ;
- CEND QUIT
- +1 ;
- C1 ;LOOP THRU CODES AND ADD TO ^TMP("CN",$J,ARRAY)
- +1 FOR PRCHK=2,4,5
- SET PRCHY=$PIECE(PRCHX,U,PRCHK)
- if PRCHY
- DO C2
- +2 ;LOOP THRU BREAKOUT CODES AND ADD TO ^TMP("CN",$J,ARRAY)
- +3 SET PRCHL=0
- FOR PRCHO=0:0
- SET PRCHL=$ORDER(^PRC(442,D0,9,PRCHJ,1,PRCHL))
- if PRCHL'>0
- QUIT
- IF $DATA(^(PRCHL,0))
- SET PRCHY=$PIECE(^(0),U,1)
- if PRCHY
- DO C2
- +4 QUIT
- +5 ;
- C2 if '$DATA(^PRCD(420.6,PRCHY,0))
- QUIT
- +1 SET PRCHC=$PIECE(^PRCD(420.6,PRCHY,0),U,1)
- SET ^TMP("CN",$JOB,PRCHC)=^TMP("CN",$JOB,PRCHC)+1
- SET PRCHA=$PIECE(PRCHX,U,1)
- SET ^TMP("CN",$JOB,PRCHC,"A")=^TMP("CN",$JOB,PRCHC,"A")+PRCHA
- +2 QUIT