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 Nov 22, 2024@17:27:02 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
