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 Oct 16, 2024@18:08:15 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
