source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCRIA.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1PRCRIA ;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 ;
5EN ;
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
14DEV ;
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
19LOOP ;
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
43EXIT ;
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
48PRINT ;
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
64HEADER ;
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
Note: See TracBrowser for help on using the repository browser.