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 Apr 09, 2024@20:59:58 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)
