Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCNPRNT

PRCNPRNT.m

Go to the documentation of this file.
  1. PRCNPRNT ;SSI/SEB-Display an NX transaction ;[ 01/30/97 1:30 PM ]
  1. ;;1.0;PRCN;**3**;Sep 13, 1996
  1. ;
  1. ; Needs IN to be set to internal # of transaction,
  1. ; PRCNUSR = user code: 0:requestor/CMR official, 1=PPM Committee I,
  1. ; 2=Engineering Committee, 3=PPM II, 4=Director, 5=Concurring Officials,
  1. ; 6=PPM III, 7=VACO Chief of Supply, 8=Equipment Committee.
  1. ;
  1. S DIC("A")="Enter TRANSACTION #: ",DIC="^PRCN(413,",DIC(0)="AEQ" D ^DIC
  1. S IN=+Y G EXIT:IN<0 S ST=$P(^PRCN(413,IN,0),U,7),PRCNTDA=$P(^(0),U,11)
  1. 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)
  1. SETUP ; Set up necessary variables & open device
  1. VIEWA W !!,"Do you want to view the information related to this request"
  1. S %=1 D YN^DICN Q:%=2!(%<0)
  1. I %=0 D G VIEWA
  1. . W !,"Enter 'YES' if you want to see a display of the information related"
  1. . W !,"to this request."
  1. S %ZIS="Q" D ^%ZIS Q:POP
  1. I $D(IO("Q")) D QUE^PRCNPR2 Q
  1. Q:$D(DUOUT) I $E(IOST)="C" W @IOF
  1. I $E(IOST)'="C" U IO
  1. BEG S NL=0,FF=0,PRCNDEEP=0,N=413,GLO="^PRCN(413,",OFN=.01,PROG="PRNT"
  1. FORMAT ; Deal with special field formatting
  1. S F(413)="3^5^6^7^15^16^30^55^56^57^46",F(413.015)=".01^2^4^6"
  1. S F(413.028)=.01,F(413.046)=1,F(6914)="1^4"
  1. SUBS ; Handle subfields
  1. G:PRCNDEEP=0 REQCMR I N=413.015 D Q
  1. . F FN=.01,1,15,2:1:8 Q:$D(DUOUT) D PRFLD(FN)
  1. . Q:$D(DUOUT) D:PRCNUSR>1 PRFLD(13)
  1. . W !
  1. I N=413.046 D Q
  1. . S PNAME=$P(@(GLO_"IN,0)"),U),NAME=$P(^PRCN(413.3,PNAME,0),U)
  1. . W !,?4,"NAME: ",$P(^VA(200,NAME,0),U),?45,"TITLE: "
  1. . S TITLE=$P(^VA(200,NAME,0),U,9) W:TITLE]"" $P(^DIC(3.1,TITLE,0),U)
  1. . F FN=1,2,4 Q:$D(DUOUT) D PRFLD(FN)
  1. . S:$P($G(@(GLO_IN_",0)")),U,2)="N" QF=""
  1. Q:$D(DUOUT) S FN=0
  1. F S FN=$O(^DD(N,FN)) Q:FN="B"!($D(DUOUT)) D PRFLD(FN)
  1. Q
  1. TURNIN ; Print stuff for turn-in
  1. S IN=$P(^PRCN(413.1,TDA,1,TI,0),U),PRCNTDA=TDA
  1. TI2 S F(6914)="1^4",N=6914,GLO="^ENG(6914,",PRCNDEEP=1,FF=0
  1. I '$D(IOST) D Q:POP>0
  1. . S %ZIS="Q" D ^%ZIS
  1. . I $D(IO("Q")) D QUT^PRCNPR2 Q
  1. TN I $E(IOST)'="C" U IO
  1. S FN=.01 D PRFLD(FN) Q:$D(DUOUT) S FF=0
  1. F FN=3,1,4,5,17,18,12,13,19,16,24 D PRFLD(FN) Q:$D(DUOUT)
  1. S F(413.11)=".5^.7^1",N=413.11,GLO="^PRCN(413.1,"_PRCNTDA_",1,",PRCNDEEP=1,FF=0
  1. F FN=.5,.7,1 NEW IN S IN=TI D PRFLD(FN) Q:$D(DUOUT)
  1. S IN=TDA,F(413.1)=16,N=413.1,GLO="^PRCN(413.1,",PRCNDEEP=1,FF=0
  1. F FN=16 D PRFLD(FN) Q:$D(DUOUT)
  1. W !
  1. Q
  1. REQCMR ; Print fields seen by requestor/CMR official review
  1. F FN=.01,1:1:15 D PRFLD(FN) Q:$D(DUOUT)
  1. I $P(^PRCN(413,IN,0),U,9)="R" S (PRCNTDA,TDA)=$P(^(0),U,11),TI=0 D
  1. . W !!,"TURN-IN LINE ITEMS:" S NL=NL+1 D CHKPG Q:$D(DUOUT)
  1. . S TMP=IN F S TI=$O(^PRCN(413.1,TDA,1,TI)) Q:TI'>0!($D(DUOUT)) D
  1. .. W !,?4,"EQ. REQUEST LINE NUMBER: ",$P(^PRCN(413.1,TDA,1,TI,0),U,3)
  1. .. D CHKPG,TURNIN:'$D(DUOUT)
  1. . S N=413,GLO="^PRCN(413,",IN=TMP,PRCNDEEP=0 K TMP
  1. Q:$D(DUOUT) F FN=126,16:1:31,100:1:104 D PRFLD(FN) Q:$D(DUOUT)
  1. PPM ; Print fields seen by PPM 1 official review
  1. G:PRCNUSR<1!($D(DUOUT)) EXIT
  1. S FN2=$S($P($G(^PRCN(413,IN,2)),U,16)="N":105,1:34) S:FN2=105 QF=""
  1. F FN=32,FN2 D PRFLD(FN) Q:$D(DUOUT)!($D(QF))
  1. ENGIN ; Print fields seen by Engineering Committee
  1. G:PRCNUSR<2!($D(DUOUT))!($D(QF)) EXIT
  1. D PRFLD(35),PRFLD(121):$P($G(^PRCN(413,IN,4)),U)="N"
  1. PPM2 ; Print fields seen by PPM 2 official review
  1. G:PRCNUSR<3!($D(DUOUT))!($D(QF)) EXIT
  1. F FN=52:1:72,74,117:1:120 D PRFLD(FN) Q:$D(DUOUT)
  1. CONCUR ; Print fields seen by Concurring Official
  1. G:PRCNUSR<5!($D(DUOUT))!($D(QF)) EXIT
  1. PPM3 ; Print fields seen by PPM 3 official review
  1. G:PRCNUSR<6!($D(DUOUT))!($D(QF)) EXIT
  1. F FN=45,46,49 D PRFLD(FN) Q:$D(DUOUT)
  1. CHIEF ; Print fields seen by VACO Chief of Supply
  1. G:PRCNUSR<7!($D(DUOUT))!($D(QF)) EXIT S PRCNDATA=$G(^PRCN(413,IN,4))
  1. F FN=36,37 D PRFLD(FN) Q:$D(DUOUT)
  1. EQUIP ; Print fields seen by Equipment Committee
  1. G:PRCNUSR<8!($D(DUOUT))!($D(QF)) EXIT
  1. I $P($G(^PRCN(413,IN,8)),U,9)]"" F FN=77 D PRFLD(FN) Q:$D(DUOUT)
  1. EXIT K DUOUT,QF I $E(IOST)'="C" W @IOF
  1. K CODES,F,FF,FN,FN2,GLO,I,ID,J,N,N2,NEWL,NL,OFN,OGLO,OID,OIN,PNAME
  1. K OPC,PC,PGL,PRCNDATA,PRCNDD,PRCNDEEP,PROG,PV,VAL,C,V,NAME
  1. D ^%ZISC
  1. Q
  1. PRFLD(FN) ; Print a single field
  1. I $$ISWP(FN) S FF=0 G PR2
  1. G:'$D(F(N)) PR2 I F(N)="" S FF=0 G PR2
  1. F I=1:1 S NEWL=$P(F(N),U,I) Q:NEWL=""!(NEWL=FN)
  1. S:NEWL=FN!(PRCNDEEP>1) FF=0
  1. PR2 D:'FF CHKPG Q:$D(DUOUT) X "W "_$S(FF:"?41",1:"!") S FF='FF
  1. D PR^PRCNPR2 S:$$ISWP(FN) FF=0 Q
  1. CHKPG ; Clear screen if it is full & start new one
  1. I $G(C)=U Q
  1. S NL=NL+1 Q:NL<(IOSL-4) I $E(IOST)'="C" W @IOF S NL=0 Q
  1. F R !!,"Press RETURN to continue, or '^' to exit. ",C:DTIME S:'$T C=U Q:U[C W $C(7)
  1. I C="^" S DUOUT="" Q
  1. W @IOF S NL=0 Q
  1. ISWP(FN) ; Check if field is word-processing or similar
  1. 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)