- 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 Feb 18, 2025@23:21:07 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)
