PRCNEQA2 ;SSI/ALA-Equipment Committee Approval ;[ 09/11/96 2:01 PM ]
;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
BEG K DIR,Y,^TMP($J,"APP") S PRCNX=0,PRCNT=0,PRCNZ=-17,PG=1
BLST ; Build list of Equipment Requests
S PRCNX=$O(^PRCN(413,PRCNX)) G:PRCNX'>0 BPRT
I $P(^PRCN(413,PRCNX,0),U,7)=31 D
. S PRCNT=PRCNT+1,^TMP($J,"APP",PG,PRCNT)=PRCNX
. I PRCNT=12 S PG=PG+1
G BLST
BPRT ; Update display number and print a screenful
S NPG=PG,PG=1
BLP ; Main loop: get input & process help
D HDR
I PRCNT=0 D Q
. W !!,"NO RECORDS TO PROCESS"
. R !!,"Press return to continue: ",PRCNX:DTIME
K ^TMP($J,"APP","D"),DUOUT S X=0,ER=0,ER(0)=""
SEL I NPG>1 S DIR(0)="SM^S:Select Requests;N:Next Page;P:Previous Page"
I NPG=1 G SEL1
S DIR("A")="Select Action "
D ^DIR K DIR S VTI=$$UP^XLFSTR(X) I VTI["^" Q
I VTI="N",PG+1>NPG W !,"No Next Page" G SEL
I VTI="P",PG-1<1 W !,"No Previous Page" G SEL
I VTI="N" S PG=PG+1 G BLP
I VTI="P" S PG=PG-1 G BLP
SEL1 ;
S DIR("A")="Select numbers to process",DIR(0)="L^1:"_PRCNT
D ^DIR Q:$G(DIRUT)=1 S EQLS=Y K DIR,Y,X
F J=1:1 S EQDA=$P(EQLS,",",J) Q:EQDA="" D
. S PPG="" F S PPG=$O(^TMP($J,"APP",PPG)) Q:PPG="" D
.. Q:$G(^TMP($J,"APP",PPG,EQDA))=""
.. S ^TMP($J,"APP","D",^TMP($J,"APP",PPG,EQDA))=""
Q
HDR ; Prints NX header and up to 12 lines of NX data
D:'$D(IOF) HOME^%ZIS
W @IOF,?15,EQXT_" in the following Equipment Requests",!
W !,"Num#",?7,"Rank",?13,"Request #",?33,"Service",?60,"# Items",?70,"Amount",!
F I=1:1:79 W "-"
S Y="" F S Y=$O(^TMP($J,"APP",PG,Y)) Q:Y="" S D0=^TMP($J,"APP",PG,Y) D
. D GETSUMS W !,Y,?7,$P($G(^PRCN(413,D0,6)),U,3)
. W ?13,$P($G(^PRCN(413,D0,0)),U) S SERV=$P(^DIC(49,$P(^(0),U,3),0),U)
. W ?33,$E(SERV,1,25),?62,TQTY,?70,"$",$J(TOTAL,8,2)
Q
GETSUMS ; Get line item total & display stuff
S (D1,TQTY,TOTAL,LTOTAL)=0 NEW Y
F S D1=$O(^PRCN(413,D0,1,D1)) Q:'+D1 D S TQTY=TQTY+1
. S DR=15,DR(413.015)=6,DIQ(0)="C",DIQ="LBTOT"
. S DIC=413,DA=D0,DA(1)=D1,DA(413.015)=D1 NEW D1
. D EN^DIQ1
. S LBN="" F S LBN=$O(LBTOT(413.015,LBN)) Q:LBN="" D
.. S X=$G(LBTOT(413.015,LBN,6))
.. S LTOTAL=LTOTAL+X
. K DR,DIQ,LBTOT,DIC,X
S TOTAL=TOTAL+LTOTAL F FN=20,22,24,53,54,60,63,65,66 D
. S:FN<25 I=2,PN=FN-15 S:FN>25 I=7,PN=FN-51
. S COST=$P($G(^PRCN(413,D0,I)),U,PN),TOTAL=TOTAL+COST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNEQA2 2335 printed Dec 13, 2024@01:54:17 Page 2
PRCNEQA2 ;SSI/ALA-Equipment Committee Approval ;[ 09/11/96 2:01 PM ]
+1 ;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
BEG KILL DIR,Y,^TMP($JOB,"APP")
SET PRCNX=0
SET PRCNT=0
SET PRCNZ=-17
SET PG=1
BLST ; Build list of Equipment Requests
+1 SET PRCNX=$ORDER(^PRCN(413,PRCNX))
if PRCNX'>0
GOTO BPRT
+2 IF $PIECE(^PRCN(413,PRCNX,0),U,7)=31
Begin DoDot:1
+3 SET PRCNT=PRCNT+1
SET ^TMP($JOB,"APP",PG,PRCNT)=PRCNX
+4 IF PRCNT=12
SET PG=PG+1
End DoDot:1
+5 GOTO BLST
BPRT ; Update display number and print a screenful
+1 SET NPG=PG
SET PG=1
BLP ; Main loop: get input & process help
+1 DO HDR
+2 IF PRCNT=0
Begin DoDot:1
+3 WRITE !!,"NO RECORDS TO PROCESS"
+4 READ !!,"Press return to continue: ",PRCNX:DTIME
End DoDot:1
QUIT
+5 KILL ^TMP($JOB,"APP","D"),DUOUT
Press return to continue: SET X=0
SET ER=0
SET ER(0)=""
SEL IF NPG>1
SET DIR(0)="SM^S:Select Requests;N:Next Page;P:Previous Page"
+1 IF NPG=1
GOTO SEL1
+2 SET DIR("A")="Select Action "
+3 DO ^DIR
KILL DIR
SET VTI=$$UP^XLFSTR(X)
IF VTI["^"
QUIT
+4 IF VTI="N"
IF PG+1>NPG
WRITE !,"No Next Page"
GOTO SEL
+5 IF VTI="P"
IF PG-1<1
WRITE !,"No Previous Page"
GOTO SEL
+6 IF VTI="N"
SET PG=PG+1
GOTO BLP
+7 IF VTI="P"
SET PG=PG-1
GOTO BLP
SEL1 ;
+1 SET DIR("A")="Select numbers to process"
SET DIR(0)="L^1:"_PRCNT
+2 DO ^DIR
if $GET(DIRUT)=1
QUIT
SET EQLS=Y
KILL DIR,Y,X
+3 FOR J=1:1
SET EQDA=$PIECE(EQLS,",",J)
if EQDA=""
QUIT
Begin DoDot:1
+4 SET PPG=""
FOR
SET PPG=$ORDER(^TMP($JOB,"APP",PPG))
if PPG=""
QUIT
Begin DoDot:2
+5 if $GET(^TMP($JOB,"APP",PPG,EQDA))=""
QUIT
+6 SET ^TMP($JOB,"APP","D",^TMP($JOB,"APP",PPG,EQDA))=""
End DoDot:2
End DoDot:1
+7 QUIT
HDR ; Prints NX header and up to 12 lines of NX data
+1 if '$DATA(IOF)
DO HOME^%ZIS
+2 WRITE @IOF,?15,EQXT_" in the following Equipment Requests",!
+3 WRITE !,"Num#",?7,"Rank",?13,"Request #",?33,"Service",?60,"# Items",?70,"Amount",!
+4 FOR I=1:1:79
WRITE "-"
+5 SET Y=""
FOR
SET Y=$ORDER(^TMP($JOB,"APP",PG,Y))
if Y=""
QUIT
SET D0=^TMP($JOB,"APP",PG,Y)
Begin DoDot:1
+6 DO GETSUMS
WRITE !,Y,?7,$PIECE($GET(^PRCN(413,D0,6)),U,3)
+7 WRITE ?13,$PIECE($GET(^PRCN(413,D0,0)),U)
SET SERV=$PIECE(^DIC(49,$PIECE(^(0),U,3),0),U)
+8 WRITE ?33,$EXTRACT(SERV,1,25),?62,TQTY,?70,"$",$JUSTIFY(TOTAL,8,2)
End DoDot:1
+9 QUIT
GETSUMS ; Get line item total & display stuff
+1 SET (D1,TQTY,TOTAL,LTOTAL)=0
NEW Y
+2 FOR
SET D1=$ORDER(^PRCN(413,D0,1,D1))
if '+D1
QUIT
Begin DoDot:1
+3 SET DR=15
SET DR(413.015)=6
SET DIQ(0)="C"
SET DIQ="LBTOT"
+4 SET DIC=413
SET DA=D0
SET DA(1)=D1
SET DA(413.015)=D1
NEW D1
+5 DO EN^DIQ1
+6 SET LBN=""
FOR
SET LBN=$ORDER(LBTOT(413.015,LBN))
if LBN=""
QUIT
Begin DoDot:2
+7 SET X=$GET(LBTOT(413.015,LBN,6))
+8 SET LTOTAL=LTOTAL+X
End DoDot:2
+9 KILL DR,DIQ,LBTOT,DIC,X
End DoDot:1
SET TQTY=TQTY+1
+10 SET TOTAL=TOTAL+LTOTAL
FOR FN=20,22,24,53,54,60,63,65,66
Begin DoDot:1
+11 if FN<25
SET I=2
SET PN=FN-15
if FN>25
SET I=7
SET PN=FN-51
+12 SET COST=$PIECE($GET(^PRCN(413,D0,I)),U,PN)
SET TOTAL=TOTAL+COST
End DoDot:1
+13 QUIT
