- PRCHRPT4 ;SF-ISC/TKW-SUPP TO PRCHRPT2--BUILD TEMP REPORT FILE FOR FPDS REPORTS ;6-12-90/08:49
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- RD ; READ THROUGH PURCHASE ORDERS (FILE 442) AND SELECT RECORDS FOR PRINTING FPDS REPORTS--BUILD ^TMP FILE TO PRINT,EXCLUDES IF,REQ AND ISSUES
- S PRCHPOR=$O(^PRC(442,PRCHPOR)) Q:'PRCHPOR S PRCHX=$G(^(PRCHPOR,0)),PRCHPONO=$P(PRCHX,U,1) G:+PRCHX'=PRC("SITE") RD G:$P(PRCHX,U,2)'=25&($P(PRCHX,U,2)'<7) RD
- S X=+$P($G(^PRC(442,PRCHPOR,1)),U,15) G:+X<FR RD I TO>0 G:+X>TO RD
- I PRCHRPT=2 S Y=X D DD^%DT S PRCHPOD=Y
- S PRCHTOTA=$P(PRCHX,U,15),PRCHTOTL=+$P(PRCHX,U,14)
- I PRCHRPT=4 S:'$D(^TMP($J)) ^($J)="" S Y=U_($P(^($J),U,2)+1)_U_($P(^($J),U,3)+PRCHTOTL)_U_($P(^($J),U,4)+PRCHTOTA) S ^($J)=Y G RD
- I PRCHRPT=5 S X=$P(PRCHX,U,3) G:X="" RD G:(+X<PRCHFR) RD I PRCHTO>0 G:(+X>PRCHTO) RD
- I PRCHRPT=5 S:'$D(^TMP($J,"R","F",X)) ^(X)="" S Y=$P(^(X),U,1)_U_($P(^(X),U,2)+1)_U_($P(^(X),U,3)+PRCHTOTL)_U_($P(^(X),U,4)+PRCHTOTA) S ^(X)=Y G RD
- G:(PRCHRPT=2)&(PRCHTOTA'>10000) RD G:(PRCHRPT=1)&(PRCHTOTA>10000) RD G:(PRCHRPT=3)&(PRCHTOTA>10000) RD
- K ^TMP($J,"TEST"),^TMP($J,"TEST2") S PRCHET=0,I=0 D RDT
- G RD
- ;
- RDT ; READ THROUGH 'TYPE CODES' FOR REPORT OPTIONS 1, 2 OR 3
- S I=$O(^PRC(442,PRCHPOR,9,I)) Q:'I S Y=^(I,0),PRCHAMT=+$P(Y,U,1),PRCHCON=$P(Y,U,3) G:(PRCHRPT=3)&(PRCHCON="") RDT S:PRCHCON="" PRCHCON=" "
- I PRCHRPT=1 S X=$G(^PRCD(420.6,+$P(Y,U,2),0)),PRCHTYP=$P(X,U,1),PRCHTYPP=$P(X,U,2)
- I PRCHRPT=1,PRCHTYP]"" S:'$D(^TMP($J,"R","T",PRCHTYP)) ^(PRCHTYP)=PRCHTYPP S Y=^(PRCHTYP),X=PRCHTYP D UPDU S ^TMP($J,"R","T",PRCHTYP)=Y G RDT
- I PRCHRPT=2,PRCHPONO]"" S ^TMP($J,"R",PRCHPONO)=PRCHPOD_U_PRCHTOTL S:'$D(^TMP($J,"R",PRCHPONO,"C",PRCHCON)) ^(PRCHCON)="" S $P(^(PRCHCON),U,2)=$P(^(PRCHCON),U,2)+PRCHAMT G RDT
- I PRCHRPT=3,PRCHCON]"" S:'$D(^TMP($J,"R","C",PRCHCON)) ^(PRCHCON)="" S Y=^(PRCHCON),X=PRCHCON D UPDU S ^TMP($J,"R","C",PRCHCON)=Y G RDT
- G RDT
- ;
- UPDU I '$D(^TMP($J,"TEST",X)) S $P(Y,U,2)=$P(Y,U,2)+1,$P(Y,U,3)=$P(Y,U,3)+PRCHTOTL
- S $P(Y,U,4)=$P(Y,U,4)+PRCHAMT,^TMP($J,"TEST",X)="",J=0 D:PRCHRPT=1 RDB
- Q
- ;
- RDB ; READ THROUGH 'BREAKOUT CODES' FOR REPORT OPTION 1
- S J=$O(^PRC(442,PRCHPOR,9,I,1,J)) Q:'J S K=+^(J,0)
- S L=$G(^PRCD(420.6,K,0)),PRCHBOUT=$P(L,U,1),PRCHBOU2=$P(L,U,2) S:PRCHBOUT="" PRCHBOUT=" "
- S:'$D(^TMP($J,"R","B",PRCHBOUT)) ^(PRCHBOUT)=PRCHBOU2 S K=^(PRCHBOUT)
- I '$D(^TMP($J,"TEST2",PRCHBOUT)) S $P(K,U,2)=$P(K,U,2)+1,$P(K,U,3)=$P(K,U,3)+PRCHTOTL
- S $P(K,U,4)=$P(K,U,4)+PRCHAMT,^TMP($J,"TEST2",PRCHBOUT)="",^TMP($J,"R","B",PRCHBOUT)=K
- G RDB
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRPT4 2594 printed Apr 23, 2025@18:25 Page 2
- PRCHRPT4 ;SF-ISC/TKW-SUPP TO PRCHRPT2--BUILD TEMP REPORT FILE FOR FPDS REPORTS ;6-12-90/08:49
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- RD ; READ THROUGH PURCHASE ORDERS (FILE 442) AND SELECT RECORDS FOR PRINTING FPDS REPORTS--BUILD ^TMP FILE TO PRINT,EXCLUDES IF,REQ AND ISSUES
- +1 SET PRCHPOR=$ORDER(^PRC(442,PRCHPOR))
- if 'PRCHPOR
- QUIT
- SET PRCHX=$GET(^(PRCHPOR,0))
- SET PRCHPONO=$PIECE(PRCHX,U,1)
- if +PRCHX'=PRC("SITE")
- GOTO RD
- if $PIECE(PRCHX,U,2)'=25&($PIECE(PRCHX,U,2)'<7)
- GOTO RD
- +2 SET X=+$PIECE($GET(^PRC(442,PRCHPOR,1)),U,15)
- if +X<FR
- GOTO RD
- IF TO>0
- if +X>TO
- GOTO RD
- +3 IF PRCHRPT=2
- SET Y=X
- DO DD^%DT
- SET PRCHPOD=Y
- +4 SET PRCHTOTA=$PIECE(PRCHX,U,15)
- SET PRCHTOTL=+$PIECE(PRCHX,U,14)
- +5 IF PRCHRPT=4
- if '$DATA(^TMP($JOB))
- SET ^($JOB)=""
- SET Y=U_($PIECE(^($JOB),U,2)+1)_U_($PIECE(^($JOB),U,3)+PRCHTOTL)_U_($PIECE(^($JOB),U,4)+PRCHTOTA)
- SET ^($JOB)=Y
- GOTO RD
- +6 IF PRCHRPT=5
- SET X=$PIECE(PRCHX,U,3)
- if X=""
- GOTO RD
- if (+X<PRCHFR)
- GOTO RD
- IF PRCHTO>0
- if (+X>PRCHTO)
- GOTO RD
- +7 IF PRCHRPT=5
- if '$DATA(^TMP($JOB,"R","F",X))
- SET ^(X)=""
- SET Y=$PIECE(^(X),U,1)_U_($PIECE(^(X),U,2)+1)_U_($PIECE(^(X),U,3)+PRCHTOTL)_U_($PIECE(^(X),U,4)+PRCHTOTA)
- SET ^(X)=Y
- GOTO RD
- +8 if (PRCHRPT=2)&(PRCHTOTA'>10000)
- GOTO RD
- if (PRCHRPT=1)&(PRCHTOTA>10000)
- GOTO RD
- if (PRCHRPT=3)&(PRCHTOTA>10000)
- GOTO RD
- +9 KILL ^TMP($JOB,"TEST"),^TMP($JOB,"TEST2")
- SET PRCHET=0
- SET I=0
- DO RDT
- +10 GOTO RD
- +11 ;
- RDT ; READ THROUGH 'TYPE CODES' FOR REPORT OPTIONS 1, 2 OR 3
- +1 SET I=$ORDER(^PRC(442,PRCHPOR,9,I))
- if 'I
- QUIT
- SET Y=^(I,0)
- SET PRCHAMT=+$PIECE(Y,U,1)
- SET PRCHCON=$PIECE(Y,U,3)
- if (PRCHRPT=3)&(PRCHCON="")
- GOTO RDT
- if PRCHCON=""
- SET PRCHCON=" "
- +2 IF PRCHRPT=1
- SET X=$GET(^PRCD(420.6,+$PIECE(Y,U,2),0))
- SET PRCHTYP=$PIECE(X,U,1)
- SET PRCHTYPP=$PIECE(X,U,2)
- +3 IF PRCHRPT=1
- IF PRCHTYP]""
- if '$DATA(^TMP($JOB,"R","T",PRCHTYP))
- SET ^(PRCHTYP)=PRCHTYPP
- SET Y=^(PRCHTYP)
- SET X=PRCHTYP
- DO UPDU
- SET ^TMP($JOB,"R","T",PRCHTYP)=Y
- GOTO RDT
- +4 IF PRCHRPT=2
- IF PRCHPONO]""
- SET ^TMP($JOB,"R",PRCHPONO)=PRCHPOD_U_PRCHTOTL
- if '$DATA(^TMP($JOB,"R",PRCHPONO,"C",PRCHCON))
- SET ^(PRCHCON)=""
- SET $PIECE(^(PRCHCON),U,2)=$PIECE(^(PRCHCON),U,2)+PRCHAMT
- GOTO RDT
- +5 IF PRCHRPT=3
- IF PRCHCON]""
- if '$DATA(^TMP($JOB,"R","C",PRCHCON))
- SET ^(PRCHCON)=""
- SET Y=^(PRCHCON)
- SET X=PRCHCON
- DO UPDU
- SET ^TMP($JOB,"R","C",PRCHCON)=Y
- GOTO RDT
- +6 GOTO RDT
- +7 ;
- UPDU IF '$DATA(^TMP($JOB,"TEST",X))
- SET $PIECE(Y,U,2)=$PIECE(Y,U,2)+1
- SET $PIECE(Y,U,3)=$PIECE(Y,U,3)+PRCHTOTL
- +1 SET $PIECE(Y,U,4)=$PIECE(Y,U,4)+PRCHAMT
- SET ^TMP($JOB,"TEST",X)=""
- SET J=0
- if PRCHRPT=1
- DO RDB
- +2 QUIT
- +3 ;
- RDB ; READ THROUGH 'BREAKOUT CODES' FOR REPORT OPTION 1
- +1 SET J=$ORDER(^PRC(442,PRCHPOR,9,I,1,J))
- if 'J
- QUIT
- SET K=+^(J,0)
- +2 SET L=$GET(^PRCD(420.6,K,0))
- SET PRCHBOUT=$PIECE(L,U,1)
- SET PRCHBOU2=$PIECE(L,U,2)
- if PRCHBOUT=""
- SET PRCHBOUT=" "
- +3 if '$DATA(^TMP($JOB,"R","B",PRCHBOUT))
- SET ^(PRCHBOUT)=PRCHBOU2
- SET K=^(PRCHBOUT)
- +4 IF '$DATA(^TMP($JOB,"TEST2",PRCHBOUT))
- SET $PIECE(K,U,2)=$PIECE(K,U,2)+1
- SET $PIECE(K,U,3)=$PIECE(K,U,3)+PRCHTOTL
- +5 SET $PIECE(K,U,4)=$PIECE(K,U,4)+PRCHAMT
- SET ^TMP($JOB,"TEST2",PRCHBOUT)=""
- SET ^TMP($JOB,"R","B",PRCHBOUT)=K
- +6 GOTO RDB
