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