source: FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNPRNT.m@ 1353

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1PRCNPRNT ;SSI/SEB-Display an NX transaction ;[ 01/30/97 1:30 PM ]
2 ;;1.0;PRCN;**3**;Sep 13, 1996
3 ;
4 ; Needs IN to be set to internal # of transaction,
5 ; PRCNUSR = user code: 0:requestor/CMR official, 1=PPM Committee I,
6 ; 2=Engineering Committee, 3=PPM II, 4=Director, 5=Concurring Officials,
7 ; 6=PPM III, 7=VACO Chief of Supply, 8=Equipment Committee.
8 ;
9 S DIC("A")="Enter TRANSACTION #: ",DIC="^PRCN(413,",DIC(0)="AEQ" D ^DIC
10 S IN=+Y G EXIT:IN<0 S ST=$P(^PRCN(413,IN,0),U,7),PRCNTDA=$P(^(0),U,11)
11 S PRCNUSR=$S(ST<4:0,ST<7:1,ST=7!(ST=13):4,ST=8!(ST=11):2,ST=28:7,ST=15!(ST=32):6,ST=26!(ST=27)!(ST=30):3,ST=10!(ST=20)!(ST=29)!(ST=33):8,ST<15:5,1:3)
12SETUP ; Set up necessary variables & open device
13VIEWA W !!,"Do you want to view the information related to this request"
14 S %=1 D YN^DICN Q:%=2!(%<0)
15 I %=0 D G VIEWA
16 . W !,"Enter 'YES' if you want to see a display of the information related"
17 . W !,"to this request."
18 S %ZIS="Q" D ^%ZIS Q:POP
19 I $D(IO("Q")) D QUE^PRCNPR2 Q
20 Q:$D(DUOUT) I $E(IOST)="C" W @IOF
21 I $E(IOST)'="C" U IO
22BEG S NL=0,FF=0,PRCNDEEP=0,N=413,GLO="^PRCN(413,",OFN=.01,PROG="PRNT"
23FORMAT ; Deal with special field formatting
24 S F(413)="3^5^6^7^15^16^30^55^56^57^46",F(413.015)=".01^2^4^6"
25 S F(413.028)=.01,F(413.046)=1,F(6914)="1^4"
26SUBS ; Handle subfields
27 G:PRCNDEEP=0 REQCMR I N=413.015 D Q
28 . F FN=.01,1,15,2:1:8 Q:$D(DUOUT) D PRFLD(FN)
29 . Q:$D(DUOUT) D:PRCNUSR>1 PRFLD(13)
30 . W !
31 I N=413.046 D Q
32 . S PNAME=$P(@(GLO_"IN,0)"),U),NAME=$P(^PRCN(413.3,PNAME,0),U)
33 . W !,?4,"NAME: ",$P(^VA(200,NAME,0),U),?45,"TITLE: "
34 . S TITLE=$P(^VA(200,NAME,0),U,9) W:TITLE]"" $P(^DIC(3.1,TITLE,0),U)
35 . F FN=1,2,4 Q:$D(DUOUT) D PRFLD(FN)
36 . S:$P($G(@(GLO_IN_",0)")),U,2)="N" QF=""
37 Q:$D(DUOUT) S FN=0
38 F S FN=$O(^DD(N,FN)) Q:FN="B"!($D(DUOUT)) D PRFLD(FN)
39 Q
40TURNIN ; Print stuff for turn-in
41 S IN=$P(^PRCN(413.1,TDA,1,TI,0),U),PRCNTDA=TDA
42TI2 S F(6914)="1^4",N=6914,GLO="^ENG(6914,",PRCNDEEP=1,FF=0
43 I '$D(IOST) D Q:POP>0
44 . S %ZIS="Q" D ^%ZIS
45 . I $D(IO("Q")) D QUT^PRCNPR2 Q
46TN I $E(IOST)'="C" U IO
47 S FN=.01 D PRFLD(FN) Q:$D(DUOUT) S FF=0
48 F FN=3,1,4,5,17,18,12,13,19,16,24 D PRFLD(FN) Q:$D(DUOUT)
49 S F(413.11)=".5^.7^1",N=413.11,GLO="^PRCN(413.1,"_PRCNTDA_",1,",PRCNDEEP=1,FF=0
50 F FN=.5,.7,1 NEW IN S IN=TI D PRFLD(FN) Q:$D(DUOUT)
51 S IN=TDA,F(413.1)=16,N=413.1,GLO="^PRCN(413.1,",PRCNDEEP=1,FF=0
52 F FN=16 D PRFLD(FN) Q:$D(DUOUT)
53 W !
54 Q
55REQCMR ; Print fields seen by requestor/CMR official review
56 F FN=.01,1:1:15 D PRFLD(FN) Q:$D(DUOUT)
57 I $P(^PRCN(413,IN,0),U,9)="R" S (PRCNTDA,TDA)=$P(^(0),U,11),TI=0 D
58 . W !!,"TURN-IN LINE ITEMS:" S NL=NL+1 D CHKPG Q:$D(DUOUT)
59 . S TMP=IN F S TI=$O(^PRCN(413.1,TDA,1,TI)) Q:TI'>0!($D(DUOUT)) D
60 .. W !,?4,"EQ. REQUEST LINE NUMBER: ",$P(^PRCN(413.1,TDA,1,TI,0),U,3)
61 .. D CHKPG,TURNIN:'$D(DUOUT)
62 . S N=413,GLO="^PRCN(413,",IN=TMP,PRCNDEEP=0 K TMP
63 Q:$D(DUOUT) F FN=126,16:1:31,100:1:104 D PRFLD(FN) Q:$D(DUOUT)
64PPM ; Print fields seen by PPM 1 official review
65 G:PRCNUSR<1!($D(DUOUT)) EXIT
66 S FN2=$S($P($G(^PRCN(413,IN,2)),U,16)="N":105,1:34) S:FN2=105 QF=""
67 F FN=32,FN2 D PRFLD(FN) Q:$D(DUOUT)!($D(QF))
68ENGIN ; Print fields seen by Engineering Committee
69 G:PRCNUSR<2!($D(DUOUT))!($D(QF)) EXIT
70 D PRFLD(35),PRFLD(121):$P($G(^PRCN(413,IN,4)),U)="N"
71PPM2 ; Print fields seen by PPM 2 official review
72 G:PRCNUSR<3!($D(DUOUT))!($D(QF)) EXIT
73 F FN=52:1:72,74,117:1:120 D PRFLD(FN) Q:$D(DUOUT)
74CONCUR ; Print fields seen by Concurring Official
75 G:PRCNUSR<5!($D(DUOUT))!($D(QF)) EXIT
76PPM3 ; Print fields seen by PPM 3 official review
77 G:PRCNUSR<6!($D(DUOUT))!($D(QF)) EXIT
78 F FN=45,46,49 D PRFLD(FN) Q:$D(DUOUT)
79CHIEF ; Print fields seen by VACO Chief of Supply
80 G:PRCNUSR<7!($D(DUOUT))!($D(QF)) EXIT S PRCNDATA=$G(^PRCN(413,IN,4))
81 F FN=36,37 D PRFLD(FN) Q:$D(DUOUT)
82EQUIP ; Print fields seen by Equipment Committee
83 G:PRCNUSR<8!($D(DUOUT))!($D(QF)) EXIT
84 I $P($G(^PRCN(413,IN,8)),U,9)]"" F FN=77 D PRFLD(FN) Q:$D(DUOUT)
85EXIT K DUOUT,QF I $E(IOST)'="C" W @IOF
86 K CODES,F,FF,FN,FN2,GLO,I,ID,J,N,N2,NEWL,NL,OFN,OGLO,OID,OIN,PNAME
87 K OPC,PC,PGL,PRCNDATA,PRCNDD,PRCNDEEP,PROG,PV,VAL,C,V,NAME
88 D ^%ZISC
89 Q
90PRFLD(FN) ; Print a single field
91 I $$ISWP(FN) S FF=0 G PR2
92 G:'$D(F(N)) PR2 I F(N)="" S FF=0 G PR2
93 F I=1:1 S NEWL=$P(F(N),U,I) Q:NEWL=""!(NEWL=FN)
94 S:NEWL=FN!(PRCNDEEP>1) FF=0
95PR2 D:'FF CHKPG Q:$D(DUOUT) X "W "_$S(FF:"?41",1:"!") S FF='FF
96 D PR^PRCNPR2 S:$$ISWP(FN) FF=0 Q
97CHKPG ; Clear screen if it is full & start new one
98 I $G(C)=U Q
99 S NL=NL+1 Q:NL<(IOSL-4) I $E(IOST)'="C" W @IOF S NL=0 Q
100 F R !!,"Press RETURN to continue, or '^' to exit. ",C:DTIME S:'$T C=U Q:U[C W $C(7)
101 I C="^" S DUOUT="" Q
102 W @IOF S NL=0 Q
103ISWP(FN) ; Check if field is word-processing or similar
104 S N2=$P(^DD(N,FN,0),U,2) Q:N2="W" 1 Q:+N2=0 0 Q ($P(^DD(+N2,0),U,4)=1)
Note: See TracBrowser for help on using the repository browser.