- PRCRIA ;GAI/CES/WASH IRMFO - DIRECTIVE 7127/MULT SIGNING OF P.O. ;8/27/96 15:36
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN ;
- S U="^",PAGE=1,(OUT,ZXX)=""
- N TXT
- S TXT(1)="For proper format, this report MUST be printed"
- S TXT(2)="in LANDSCAPE mode (16 or 17 cpi)"
- D HDRBOX^PRCRIA10(.TXT)
- S ZXX=$$DATERNG^PRCRIA1
- D DEV
- Q
- DEV ;
- Q:$G(ZXX)=""
- S %IS="QM" D ^%ZIS G:POP EXIT
- I $D(IO("Q")) S ZTSAVE("*")="",ZTDESC="DIRECTIVE 7127/MULT SIGNING OF P.O.",ZTRTN="LOOP^PRCRIA" D ^%ZTLOAD I $D(ZTSK) W !,"Task #",ZTSK," queued to print." G EXIT
- U IO
- LOOP ;
- ;-------------------------------------------------------------
- ;This loops through the Date of P.O. x-ref for p.o.'s within
- ; the date range specified. Saves only thos p.o.'s with
- ; at match in at least 2 of the 3 questioned fields.
- ;-------------------------------------------------------------
- K ^TMP("PRCRIA")
- S (IEN,APOFF,PAGNT,WHPER,PONUM,REFNUM,PODT,FCP,RCV,PRTDT)="",FLAG=0
- F S PODT=$O(^PRC(442,"AB",PODT)) Q:PODT="" D
- .F S IEN=$O(^PRC(442,"AB",+PODT,IEN)) Q:IEN="" D
- ..I PODT>($P(ZXX,U)-1),PODT<$P(ZXX,U,2) D
- ...S PONUM=$$GET1^DIQ(442,+IEN_",",.01)
- ...S FCP=$P($G(^PRC(442,+IEN,0)),U,3)
- ...S PAGNT=$P($G(^PRC(442,+IEN,1)),U,10)
- ...F S RCV=$O(^PRC(442,+IEN,11,RCV)) Q:RCV="" D:RCV>0
- ....S WHPER=$P($G(^PRC(442,+IEN,11,+RCV,0)),U,7)
- ....S PRTDT=$P($G(^PRC(442,+IEN,11,+RCV,0)),U)
- ....F S REFNUM=$O(^PRC(442,+IEN,13,REFNUM)) Q:REFNUM="" D:REFNUM>0
- .....S APOFF=$P($G(^PRCS(410,+REFNUM,7)),U,3)
- .....I APOFF=PAGNT S FLAG=1
- .....I APOFF=WHPER S FLAG=1
- .....I PAGNT=WHPER S FLAG=1
- .....I FLAG=1 S ^TMP("PRCRIA",$J,FCP,IEN,RCV)=PONUM_U_FCP_U_REFNUM_U_PODT_U_APOFF_U_PAGNT_U_WHPER_U_PRTDT S FLAG=0
- D PRINT
- EXIT ;
- D ^%ZISC
- K ^TMP("PRCRIA"),ZXX,FCP,IEN,RCV,PONUM,REFNUM,PODT,APOFF,PAGNT,WHPER
- K PRTDT,FLAG,PAGE,TXT,NODE
- Q
- PRINT ;
- D HEADER
- S (FCP,IEN,APOFF,PAGNT,WHPER,PRTDT)=""
- F S FCP=$O(^TMP("PRCRIA",$J,FCP)) Q:'FCP D
- .F S IEN=$O(^TMP("PRCRIA",$J,FCP,IEN)) Q:IEN="" D
- ..F S RCV=$O(^TMP("PRCRIA",$J,FCP,IEN,RCV)) Q:RCV="" D
- ...I $E(IOST)="C",$Y+5>IOSL D
- ....K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W !! D ^DIR
- ...D:$Y+5>IOSL HEADER
- ...S NODE=^TMP("PRCRIA",$J,FCP,IEN,RCV)
- ...S APOFF=$P(NODE,U,5)
- ...S PAGNT=$P(NODE,U,6)
- ...S WHPER=$P(NODE,U,7)
- ...S PRTDT=$P(NODE,U,8)
- ...W !,$P(NODE,U),?17,$P(NODE,U,2),?48,$P($G(^VA(200,+APOFF,0)),U),?82,$P($G(^VA(200,+PAGNT,0)),U),?120,$P($G(^VA(200,+WHPER,0)),U),?158,$P($$FMTE^XLFDT(PRTDT),"@",1)
- Q
- I PAGE>1,($E(IOST,1,2))="C-"
- W @IOF
- I $E(IOST)="C" D HDRBOX^PRCRIA10(.TXT)
- I $E(IOST)="P" W !,"REPORT FOR VA DIRECTIVE 7127.1",?50,$$FMTE^XLFDT($$DT^XLFDT),?68,"PAGE: ",PAGE,!!
- W !,"P.O.#",?17,"FCP",?48,"APPROVING OFFICIAL",?82,"PURCHASING AGENT",?120,"RECEIVING OFFICIAL",?158,"PARTIAL DATE",! W $$REPEAT^XLFSTR("-",IOM)
- S PAGE=PAGE+1
- W !
- Q
- ;PRCRIA
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCRIA 2966 printed Mar 13, 2025@21:21:46 Page 2
- PRCRIA ;GAI/CES/WASH IRMFO - DIRECTIVE 7127/MULT SIGNING OF P.O. ;8/27/96 15:36
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN ;
- +1 SET U="^"
- SET PAGE=1
- SET (OUT,ZXX)=""
- +2 NEW TXT
- +3 SET TXT(1)="For proper format, this report MUST be printed"
- +4 SET TXT(2)="in LANDSCAPE mode (16 or 17 cpi)"
- +5 DO HDRBOX^PRCRIA10(.TXT)
- +6 SET ZXX=$$DATERNG^PRCRIA1
- +7 DO DEV
- +8 QUIT
- DEV ;
- +1 if $GET(ZXX)=""
- QUIT
- +2 SET %IS="QM"
- DO ^%ZIS
- if POP
- GOTO EXIT
- +3 IF $DATA(IO("Q"))
- SET ZTSAVE("*")=""
- SET ZTDESC="DIRECTIVE 7127/MULT SIGNING OF P.O."
- SET ZTRTN="LOOP^PRCRIA"
- DO ^%ZTLOAD
- IF $DATA(ZTSK)
- WRITE !,"Task #",ZTSK," queued to print."
- GOTO EXIT
- +4 USE IO
- LOOP ;
- +1 ;-------------------------------------------------------------
- +2 ;This loops through the Date of P.O. x-ref for p.o.'s within
- +3 ; the date range specified. Saves only thos p.o.'s with
- +4 ; at match in at least 2 of the 3 questioned fields.
- +5 ;-------------------------------------------------------------
- +6 KILL ^TMP("PRCRIA")
- +7 SET (IEN,APOFF,PAGNT,WHPER,PONUM,REFNUM,PODT,FCP,RCV,PRTDT)=""
- SET FLAG=0
- +8 FOR
- SET PODT=$ORDER(^PRC(442,"AB",PODT))
- if PODT=""
- QUIT
- Begin DoDot:1
- +9 FOR
- SET IEN=$ORDER(^PRC(442,"AB",+PODT,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +10 IF PODT>($PIECE(ZXX,U)-1)
- IF PODT<$PIECE(ZXX,U,2)
- Begin DoDot:3
- +11 SET PONUM=$$GET1^DIQ(442,+IEN_",",.01)
- +12 SET FCP=$PIECE($GET(^PRC(442,+IEN,0)),U,3)
- +13 SET PAGNT=$PIECE($GET(^PRC(442,+IEN,1)),U,10)
- +14 FOR
- SET RCV=$ORDER(^PRC(442,+IEN,11,RCV))
- if RCV=""
- QUIT
- if RCV>0
- Begin DoDot:4
- +15 SET WHPER=$PIECE($GET(^PRC(442,+IEN,11,+RCV,0)),U,7)
- +16 SET PRTDT=$PIECE($GET(^PRC(442,+IEN,11,+RCV,0)),U)
- +17 FOR
- SET REFNUM=$ORDER(^PRC(442,+IEN,13,REFNUM))
- if REFNUM=""
- QUIT
- if REFNUM>0
- Begin DoDot:5
- +18 SET APOFF=$PIECE($GET(^PRCS(410,+REFNUM,7)),U,3)
- +19 IF APOFF=PAGNT
- SET FLAG=1
- +20 IF APOFF=WHPER
- SET FLAG=1
- +21 IF PAGNT=WHPER
- SET FLAG=1
- +22 IF FLAG=1
- SET ^TMP("PRCRIA",$JOB,FCP,IEN,RCV)=PONUM_U_FCP_U_REFNUM_U_PODT_U_APOFF_U_PAGNT_U_WHPER_U_PRTDT
- SET FLAG=0
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 DO PRINT
- EXIT ;
- +1 DO ^%ZISC
- +2 KILL ^TMP("PRCRIA"),ZXX,FCP,IEN,RCV,PONUM,REFNUM,PODT,APOFF,PAGNT,WHPER
- +3 KILL PRTDT,FLAG,PAGE,TXT,NODE
- +4 QUIT
- PRINT ;
- +1 DO HEADER
- +2 SET (FCP,IEN,APOFF,PAGNT,WHPER,PRTDT)=""
- +3 FOR
- SET FCP=$ORDER(^TMP("PRCRIA",$JOB,FCP))
- if 'FCP
- QUIT
- Begin DoDot:1
- +4 FOR
- SET IEN=$ORDER(^TMP("PRCRIA",$JOB,FCP,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +5 FOR
- SET RCV=$ORDER(^TMP("PRCRIA",$JOB,FCP,IEN,RCV))
- if RCV=""
- QUIT
- Begin DoDot:3
- +6 IF $EXTRACT(IOST)="C"
- IF $Y+5>IOSL
- Begin DoDot:4
- +7 KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press RETURN to continue"
- WRITE !!
- DO ^DIR
- End DoDot:4
- +8 if $Y+5>IOSL
- DO HEADER
- +9 SET NODE=^TMP("PRCRIA",$JOB,FCP,IEN,RCV)
- +10 SET APOFF=$PIECE(NODE,U,5)
- +11 SET PAGNT=$PIECE(NODE,U,6)
- +12 SET WHPER=$PIECE(NODE,U,7)
- +13 SET PRTDT=$PIECE(NODE,U,8)
- +14 WRITE !,$PIECE(NODE,U),?17,$PIECE(NODE,U,2),?48,$PIECE($GET(^VA(200,+APOFF,0)),U),?82,$PIECE($GET(^VA(200,+PAGNT,0)),U),?120,$PIECE($GET(^VA(200,+WHPER,0)),U),?158,$PIECE($$FMTE^XLFDT(PRTDT),"@",1)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +1 IF PAGE>1
- IF ($EXTRACT(IOST,1,2))="C-"
- +2 WRITE @IOF
- +3 IF $EXTRACT(IOST)="C"
- DO HDRBOX^PRCRIA10(.TXT)
- +4 IF $EXTRACT(IOST)="P"
- WRITE !,"REPORT FOR VA DIRECTIVE 7127.1",?50,$$FMTE^XLFDT($$DT^XLFDT),?68,"PAGE: ",PAGE,!!
- +5 WRITE !,"P.O.#",?17,"FCP",?48,"APPROVING OFFICIAL",?82,"PURCHASING AGENT",?120,"RECEIVING OFFICIAL",?158,"PARTIAL DATE",!
- WRITE $$REPEAT^XLFSTR("-",IOM)
- +6 SET PAGE=PAGE+1
- +7 WRITE !
- +8 QUIT
- +9 ;PRCRIA
