PRCNTIPR ;SSI/SEB-Display a NX Turn-in request ;[ 02/18/97 4:12 PM ]
;;1.0;PRCN;**2,3**;Sep 13, 1996
EN S DIC("A")="Select Turn-In TRANSACTION #: ",DIC="^PRCN(413.1,",DIC(0)="AEQ"
D ^DIC G EXIT:Y<0 S (IN,PRCNTDA)=+Y,PRCNUSR=2
SETUP ; Set up necessary variables & open device
S %ZIS="Q" D ^%ZIS G EXIT:POP
I $D(IO("Q")) D G EXIT
. S ZTRTN="BEG^PRCNTIPR",ZTDESC="Equipment Request"
. S ZTSAVE("IN")="",ZTSAVE("PRCNUSR")="",ZTSAVE("PRCNTDA")=""
. D ^%ZTLOAD,HOME^%ZIS K IO("Q"),ZTSK,%ZTLOAD,ZTREQ
G EXIT:$D(DUOUT) I $E(IOST)="C" W @IOF
BEG S NL=0,FF=0,PRCNDEEP=0,N=413.1,GLO="^PRCN(413.1,",PROG="TIPR",OFN=.01
FORMAT ; Deal with special field formatting
S F(413.1)="2^3^5^6^7^20"
REQCMR ; Print fields for requestor display or CMR Official review
F FN=.01,1,2,3,4,5,6,7 D PRFLD(FN) Q:$D(DUOUT)
I PRCNUSR>0!($G(ST)=4) F FN=9,11 D PRFLD(FN) Q:$D(DUOUT)
G EXIT:$G(TIF)=1
S TI=0 D
. W !!,"TURN-IN LINE ITEMS:" S NL=NL+1 D CHKPG Q:$D(DUOUT)
. F S TI=$O(^PRCN(413.1,PRCNTDA,1,TI)) Q:TI'>0!($D(DUOUT)) D
.. W !!,?4,"EQ. REQUEST LINE NUMBER: ",$P(^PRCN(413.1,PRCNTDA,1,TI,0),U,3) S NL=NL+1
.. S (IN,PRCNEIN)=$P(^PRCN(413.1,PRCNTDA,1,TI,0),U),TDA=PRCNTDA D TI2^PRCNPRNT
.. Q:$D(DUOUT) S IN=PRCNTDA
.. S PRCNTT=0,PRCNDT=0
.. F S PRCNDT=$O(^ENG(6914,PRCNEIN,6,PRCNDT)) Q:'PRCNDT S PRCNXX=^(PRCNDT,0) D
... F PRCNJ=5:1:7 S PRCNTT=PRCNTT+$P(PRCNXX,U,PRCNJ)
.. W !,"TOTAL REPAIR COSTS: ",PRCNTT S NL=NL+1
.. D CHKPG
PPM ; Print field seen by PPM
EXIT K DUOUT,QF,DIC,NL,FF,PRCNDEEP,N,N2,GLO,PROG,OFN,F,TIL,FN,PRCNEIN
K CODES,PRCNXX,PRCNTT,OIN,PC,PGL,PRCNDD,PRCNDT,PRCNJ
K TDA,TI,NEWL,OGLO,OID,OPC,PV,I,ID,C
I $E(IOST)'="C" W @IOF
D ^%ZISC
Q
SUBS ; Handle subfields
I N=413.11 S TIL=$P(@(GLO_"IN,0)"),U) W !,?4,"NUMBER: ",TIL,?41 D
. W "DESCRIPTION: ",$P(^ENG(6914,TIL,0),U,2),!
Q:N=413.11!($D(DUOUT)) S FN=0
F S FN=$O(^DD(N,FN)) Q:FN="B"!($D(DUOUT)) D PRFLD(FN)
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 G PQ:$D(DUOUT) X "W "_$S(FF:"?41",1:"!") S FF='FF
D PR^PRCNPR2 S:$$ISWP(FN) FF=0
PQ K NEWL,C Q
CHKPG ; Clear screen if it is full & start new one
S NL=NL+1 Q:NL<(IOSL-2) 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:C[U 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[HPRCNTIPR 2599 printed Dec 13, 2024@01:54:44 Page 2
PRCNTIPR ;SSI/SEB-Display a NX Turn-in request ;[ 02/18/97 4:12 PM ]
+1 ;;1.0;PRCN;**2,3**;Sep 13, 1996
EN SET DIC("A")="Select Turn-In TRANSACTION #: "
SET DIC="^PRCN(413.1,"
SET DIC(0)="AEQ"
+1 DO ^DIC
if Y<0
GOTO EXIT
SET (IN,PRCNTDA)=+Y
SET PRCNUSR=2
SETUP ; Set up necessary variables & open device
+1 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="BEG^PRCNTIPR"
SET ZTDESC="Equipment Request"
+4 SET ZTSAVE("IN")=""
SET ZTSAVE("PRCNUSR")=""
SET ZTSAVE("PRCNTDA")=""
+5 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q"),ZTSK,%ZTLOAD,ZTREQ
End DoDot:1
GOTO EXIT
+6 if $DATA(DUOUT)
GOTO EXIT
IF $EXTRACT(IOST)="C"
WRITE @IOF
BEG SET NL=0
SET FF=0
SET PRCNDEEP=0
SET N=413.1
SET GLO="^PRCN(413.1,"
SET PROG="TIPR"
SET OFN=.01
FORMAT ; Deal with special field formatting
+1 SET F(413.1)="2^3^5^6^7^20"
REQCMR ; Print fields for requestor display or CMR Official review
+1 FOR FN=.01,1,2,3,4,5,6,7
DO PRFLD(FN)
if $DATA(DUOUT)
QUIT
+2 IF PRCNUSR>0!($GET(ST)=4)
FOR FN=9,11
DO PRFLD(FN)
if $DATA(DUOUT)
QUIT
+3 if $GET(TIF)=1
GOTO EXIT
+4 SET TI=0
Begin DoDot:1
+5 WRITE !!,"TURN-IN LINE ITEMS:"
SET NL=NL+1
DO CHKPG
if $DATA(DUOUT)
QUIT
+6 FOR
SET TI=$ORDER(^PRCN(413.1,PRCNTDA,1,TI))
if TI'>0!($DATA(DUOUT))
QUIT
Begin DoDot:2
+7 WRITE !!,?4,"EQ. REQUEST LINE NUMBER: ",$PIECE(^PRCN(413.1,PRCNTDA,1,TI,0),U,3)
SET NL=NL+1
+8 SET (IN,PRCNEIN)=$PIECE(^PRCN(413.1,PRCNTDA,1,TI,0),U)
SET TDA=PRCNTDA
DO TI2^PRCNPRNT
+9 if $DATA(DUOUT)
QUIT
SET IN=PRCNTDA
+10 SET PRCNTT=0
SET PRCNDT=0
+11 FOR
SET PRCNDT=$ORDER(^ENG(6914,PRCNEIN,6,PRCNDT))
if 'PRCNDT
QUIT
SET PRCNXX=^(PRCNDT,0)
Begin DoDot:3
+12 FOR PRCNJ=5:1:7
SET PRCNTT=PRCNTT+$PIECE(PRCNXX,U,PRCNJ)
End DoDot:3
+13 WRITE !,"TOTAL REPAIR COSTS: ",PRCNTT
SET NL=NL+1
+14 DO CHKPG
End DoDot:2
End DoDot:1
PPM ; Print field seen by PPM
EXIT KILL DUOUT,QF,DIC,NL,FF,PRCNDEEP,N,N2,GLO,PROG,OFN,F,TIL,FN,PRCNEIN
+1 KILL CODES,PRCNXX,PRCNTT,OIN,PC,PGL,PRCNDD,PRCNDT,PRCNJ
+2 KILL TDA,TI,NEWL,OGLO,OID,OPC,PV,I,ID,C
+3 IF $EXTRACT(IOST)'="C"
WRITE @IOF
+4 DO ^%ZISC
+5 QUIT
SUBS ; Handle subfields
+1 IF N=413.11
SET TIL=$PIECE(@(GLO_"IN,0)"),U)
WRITE !,?4,"NUMBER: ",TIL,?41
Begin DoDot:1
+2 WRITE "DESCRIPTION: ",$PIECE(^ENG(6914,TIL,0),U,2),!
End DoDot:1
+3 if N=413.11!($DATA(DUOUT))
QUIT
SET FN=0
+4 FOR
SET FN=$ORDER(^DD(N,FN))
if FN="B"!($DATA(DUOUT))
QUIT
DO PRFLD(FN)
+5 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)
GOTO PQ
XECUTE "W "_$SELECT(FF:"?41",1:"!")
SET FF='FF
+1 DO PR^PRCNPR2
if $$ISWP(FN)
SET FF=0
PQ KILL NEWL,C
QUIT
CHKPG ; Clear screen if it is full & start new one
+1 SET NL=NL+1
if NL<(IOSL-2)
QUIT
IF $EXTRACT(IOST)'="C"
WRITE @IOF
SET NL=0
QUIT
+2 FOR
READ !!,"Press RETURN to continue, or '^' to exit. ",C:DTIME
if '$TEST
SET C=U
if C[U
QUIT
WRITE $CHAR(7)
+3 IF C="^"
SET DUOUT=""
QUIT
+4 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)
