| 1 | PRCRIA ;GAI/CES/WASH IRMFO - DIRECTIVE 7127/MULT SIGNING OF P.O. ;8/27/96 15:36
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | EN ;
|
|---|
| 6 | S U="^",PAGE=1,(OUT,ZXX)=""
|
|---|
| 7 | N TXT
|
|---|
| 8 | S TXT(1)="For proper format, this report MUST be printed"
|
|---|
| 9 | S TXT(2)="in LANDSCAPE mode (16 or 17 cpi)"
|
|---|
| 10 | D HDRBOX^PRCRIA10(.TXT)
|
|---|
| 11 | S ZXX=$$DATERNG^PRCRIA1
|
|---|
| 12 | D DEV
|
|---|
| 13 | Q
|
|---|
| 14 | DEV ;
|
|---|
| 15 | Q:$G(ZXX)=""
|
|---|
| 16 | S %IS="QM" D ^%ZIS G:POP EXIT
|
|---|
| 17 | 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
|
|---|
| 18 | U IO
|
|---|
| 19 | LOOP ;
|
|---|
| 20 | ;-------------------------------------------------------------
|
|---|
| 21 | ;This loops through the Date of P.O. x-ref for p.o.'s within
|
|---|
| 22 | ; the date range specified. Saves only thos p.o.'s with
|
|---|
| 23 | ; at match in at least 2 of the 3 questioned fields.
|
|---|
| 24 | ;-------------------------------------------------------------
|
|---|
| 25 | K ^TMP("PRCRIA")
|
|---|
| 26 | S (IEN,APOFF,PAGNT,WHPER,PONUM,REFNUM,PODT,FCP,RCV,PRTDT)="",FLAG=0
|
|---|
| 27 | F S PODT=$O(^PRC(442,"AB",PODT)) Q:PODT="" D
|
|---|
| 28 | .F S IEN=$O(^PRC(442,"AB",+PODT,IEN)) Q:IEN="" D
|
|---|
| 29 | ..I PODT>($P(ZXX,U)-1),PODT<$P(ZXX,U,2) D
|
|---|
| 30 | ...S PONUM=$$GET1^DIQ(442,+IEN_",",.01)
|
|---|
| 31 | ...S FCP=$P($G(^PRC(442,+IEN,0)),U,3)
|
|---|
| 32 | ...S PAGNT=$P($G(^PRC(442,+IEN,1)),U,10)
|
|---|
| 33 | ...F S RCV=$O(^PRC(442,+IEN,11,RCV)) Q:RCV="" D:RCV>0
|
|---|
| 34 | ....S WHPER=$P($G(^PRC(442,+IEN,11,+RCV,0)),U,7)
|
|---|
| 35 | ....S PRTDT=$P($G(^PRC(442,+IEN,11,+RCV,0)),U)
|
|---|
| 36 | ....F S REFNUM=$O(^PRC(442,+IEN,13,REFNUM)) Q:REFNUM="" D:REFNUM>0
|
|---|
| 37 | .....S APOFF=$P($G(^PRCS(410,+REFNUM,7)),U,3)
|
|---|
| 38 | .....I APOFF=PAGNT S FLAG=1
|
|---|
| 39 | .....I APOFF=WHPER S FLAG=1
|
|---|
| 40 | .....I PAGNT=WHPER S FLAG=1
|
|---|
| 41 | .....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
|
|---|
| 42 | D PRINT
|
|---|
| 43 | EXIT ;
|
|---|
| 44 | D ^%ZISC
|
|---|
| 45 | K ^TMP("PRCRIA"),ZXX,FCP,IEN,RCV,PONUM,REFNUM,PODT,APOFF,PAGNT,WHPER
|
|---|
| 46 | K PRTDT,FLAG,PAGE,TXT,NODE
|
|---|
| 47 | Q
|
|---|
| 48 | PRINT ;
|
|---|
| 49 | D HEADER
|
|---|
| 50 | S (FCP,IEN,APOFF,PAGNT,WHPER,PRTDT)=""
|
|---|
| 51 | F S FCP=$O(^TMP("PRCRIA",$J,FCP)) Q:'FCP D
|
|---|
| 52 | .F S IEN=$O(^TMP("PRCRIA",$J,FCP,IEN)) Q:IEN="" D
|
|---|
| 53 | ..F S RCV=$O(^TMP("PRCRIA",$J,FCP,IEN,RCV)) Q:RCV="" D
|
|---|
| 54 | ...I $E(IOST)="C",$Y+5>IOSL D
|
|---|
| 55 | ....K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W !! D ^DIR
|
|---|
| 56 | ...D:$Y+5>IOSL HEADER
|
|---|
| 57 | ...S NODE=^TMP("PRCRIA",$J,FCP,IEN,RCV)
|
|---|
| 58 | ...S APOFF=$P(NODE,U,5)
|
|---|
| 59 | ...S PAGNT=$P(NODE,U,6)
|
|---|
| 60 | ...S WHPER=$P(NODE,U,7)
|
|---|
| 61 | ...S PRTDT=$P(NODE,U,8)
|
|---|
| 62 | ...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)
|
|---|
| 63 | Q
|
|---|
| 64 | HEADER ;
|
|---|
| 65 | I PAGE>1,($E(IOST,1,2))="C-"
|
|---|
| 66 | W @IOF
|
|---|
| 67 | I $E(IOST)="C" D HDRBOX^PRCRIA10(.TXT)
|
|---|
| 68 | I $E(IOST)="P" W !,"REPORT FOR VA DIRECTIVE 7127.1",?50,$$FMTE^XLFDT($$DT^XLFDT),?68,"PAGE: ",PAGE,!!
|
|---|
| 69 | W !,"P.O.#",?17,"FCP",?48,"APPROVING OFFICIAL",?82,"PURCHASING AGENT",?120,"RECEIVING OFFICIAL",?158,"PARTIAL DATE",! W $$REPEAT^XLFSTR("-",IOM)
|
|---|
| 70 | S PAGE=PAGE+1
|
|---|
| 71 | W !
|
|---|
| 72 | Q
|
|---|
| 73 | ;PRCRIA
|
|---|
