RMPFQIP ;DDC/KAW-PRINT PRODUCT LISTS [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
Q:'$D(RMPFIT)!'$D(RMPFPG) S PA=1,Y=DT D DD^%DT S DP=Y K ^TMP("RMPF",$J)
S MU=$O(^RMPF(791810.5,"C",RMPFMENU,0)) G END:'MU S P=-1
I RMPFPG S P=RMPFPG G U11:RMPFIT="*" Q:'RMPFIT S I=RMPFIT G U3
U1 S P=$O(^RMPF(791811,"AC",P)) G PRINT:'P
U11 S I=0
U2 S I=$O(^RMPF(791811,"AC",P,I)) I 'I G PRINT:RMPFPG,U1
U3 G U2:I=1,U2:'$D(^RMPF(791811,I,0)) S S0=^(0) I $D(^("I")),$P(^("I"),U) G U2
S IT=$P(S0,U,1),MK=$P(S0,U,2),PG=$P(S0,U,3) S:MK="" MK=0
G U2:'PG,U2:'$D(^RMPF(791811.1,PG,101,"B",MU))
S CS=$P(S0,U,4),NN=$P(S0,U,5)
I PG,$D(^RMPF(791811.1,PG,0)) S PG=$P(^(0),U,1)
S ^TMP("RMPF",$J,PG,MK,IT,I)=NN_U_CS
G U2:'RMPFIT
PRINT S (CT,PG)=0
PG S PG=$O(^TMP("RMPF",$J,PG)) G EXIT:PG=""
S X=$O(^RMPF(791811.1,"B",PG,0)),PP=0
I X,$D(^RMPF(791811.1,X,0)) S PP=$P(^(0),U,2)
IT S MK=-1,PP=$S(PP="CHA"!(PP="SHA")!(PP="ALD"):0,1:1) D HEAD
D @("HEAD"_PP)
IT1 S MK=$O(^TMP("RMPF",$J,PG,MK)) I MK="" D CONT:IOST?1"C-".E G PG
S IT=0
IT2 S IT=$O(^TMP("RMPF",$J,PG,MK,IT)) G IT1:IT="" S DA=0
IT3 S DA=$O(^TMP("RMPF",$J,PG,MK,IT,DA)) G IT2:'DA,IT3:DA=1
G IT3:'$D(^RMPF(791811,DA,0)) S S0=^(0) I $D(^("I")),$P(^("I"),U) G IT3
S CS=$P(S0,U,4),MR=$P(S0,U,6),UI=$P(S0,U,8),NN=$P(S0,U,5) S:'UI UI=1
S AM=$P(S0,U,9) ;I MR S CS=CS*(1+(MR*.01))
I $Y>(IOSL-3),IOST?1"C-".E D CRT G END:$D(RMPFOUT)
I $Y>58,IOST?1"P-".E D PRT
I 'PP D AIDS G END:$D(RMPFOUT) G IT3:'RMPFIT,EXIT
W !!,$E(IT,1,30),?33,$J(CS,8,2),?43,$J(UI,7,0),?58,NN,?76,AM S CT=CT+1
G IT3:'RMPFIT
EXIT W !!,"Total Items Printed: ",CT W:IOST?1"P-".E @IOF
D:$D(IO("S")) ^%ZISC
END K B,BP,BT,C,C1,CM,CP,CS,CT,DA,DP,I,IT,MK,NN,PA,PG,S0,P,Y,^TMP("RMPF",$J)
K RMPFBT,RMPFCM,RMPFIT,RMPFOUT,RMPFPG,RMPFQUT,PP,UI,X,POP,MR,CD,AM Q
AIDS D WRITE S (CM,BT)=0,CT=CT+1 K RMPFBT,RMPFCM
F I=1:1 S BT=$O(^RMPF(791811,DA,102,BT)) Q:'BT I $D(^(BT,0)) S B=$P(^(0),U,1) I B,$D(^RMPF(791811.3,B,0)) S BP=$P(^(0),U,1),RMPFBT(BP)=""
F I=1:1 S CM=$O(^RMPF(791811,DA,101,CM)) Q:'CM I $D(^(CM,0)) S C=$P(^(0),U,1) I C,$D(^RMPF(791811.2,C,0)) S CP=$P(^(0),U,1),CD=$P(^(0),U,3) I CP'="" S RMPFCM(CP)=$P(^RMPF(791811,DA,101,CM,0),U,2)_U_CD
S (BT,CM)=0
F I=1:1 Q:'$D(RMPFCM)&'$D(RMPFBT) D Q:$D(RMPFOUT)
.W:C1 ! S C1=C1+1
.S BT=$O(RMPFCM(BT))
.I BT'="" S (X,S)=$P(RMPFCM(BT),U,1) S:MR="TAKE THIS OUT" S=X*(1+(MR*.01)) W ?37,$E(BT,1,19),?58,$E($P(RMPFCM(BT),U,2),1,8),?68,$J(S,5,2) K RMPFCM(BT)
.S CM=$O(RMPFBT(CM)) I CM'="" W ?75,$E(CM,1,8) K RMPFBT(CM)
.I $Y>21,IOST?1"C-".E D CRT Q:$D(RMPFOUT) D WRITE
.I $Y>58,IOST?1"P-".E D PRT
.Q
Q
WRITE W !!,$E(IT,1,16),?18,$E(MK,1,9),?29,$J(CS,6,2) S C1=0 Q
CONT F Q:$Y>22 W !
W !,"Enter <RETURN> to continue." D READ Q:$D(RMPFOUT)
I $D(RMPFQUT) W !!,"Enter a <RETURN> to continue viewing or an <^> to exit." G CONT
Q:Y="" G CONT Q
READ K RMPFOUT,RMPFQUT
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
I Y?1"^".E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
CRT D CONT Q:$D(RMPFOUT) D HEAD,@("HEAD"_PP) W !,"cont." Q
PRT D HEAD,@("HEAD"_PP) W !,"cont." Q
HEAD W @IOF,!?27,"REMOTE ORDER/ENTRY SYSTEM",?72,"page: ",PA S PA=PA+1
W !?32,"PRODUCT LISTING"
W !!,"Product Group: ",PG,?56,"Print Date: ",DP
W ! F I=1:1:80 W "-"
Q
HEAD0 W !?5,"Model",?20,"Make",?29,"Price",?42,"Component",?60,"Code"
W ?68,"Price",?75,"Batt."
W !,"----------------",?18,"---------",?29,"------",?37,"-------------------",?58,"--------"
W ?68,"-----",?75,"-----"
Q
HEAD1 W !?13,"Item",?35,"Price",?43,"Unit of Issue",?64,"NSN",?76,"AMIS"
W !,"-------------------------------",?33,"--------",?43,"-------------",?58,"----------------",?76,"----"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQIP 3710 printed Apr 09, 2024@21:38:59 Page 2
RMPFQIP ;DDC/KAW-PRINT PRODUCT LISTS [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
+2 if '$DATA(RMPFIT)!'$DATA(RMPFPG)
QUIT
SET PA=1
SET Y=DT
DO DD^%DT
SET DP=Y
KILL ^TMP("RMPF",$JOB)
+3 SET MU=$ORDER(^RMPF(791810.5,"C",RMPFMENU,0))
if 'MU
GOTO END
SET P=-1
+4 IF RMPFPG
SET P=RMPFPG
if RMPFIT="*"
GOTO U11
if 'RMPFIT
QUIT
SET I=RMPFIT
GOTO U3
U1 SET P=$ORDER(^RMPF(791811,"AC",P))
if 'P
GOTO PRINT
U11 SET I=0
U2 SET I=$ORDER(^RMPF(791811,"AC",P,I))
IF 'I
if RMPFPG
GOTO PRINT
GOTO U1
U3 if I=1
GOTO U2
if '$DATA(^RMPF(791811,I,0))
GOTO U2
SET S0=^(0)
IF $DATA(^("I"))
IF $PIECE(^("I"),U)
GOTO U2
+1 SET IT=$PIECE(S0,U,1)
SET MK=$PIECE(S0,U,2)
SET PG=$PIECE(S0,U,3)
if MK=""
SET MK=0
+2 if 'PG
GOTO U2
if '$DATA(^RMPF(791811.1,PG,101,"B",MU))
GOTO U2
+3 SET CS=$PIECE(S0,U,4)
SET NN=$PIECE(S0,U,5)
+4 IF PG
IF $DATA(^RMPF(791811.1,PG,0))
SET PG=$PIECE(^(0),U,1)
+5 SET ^TMP("RMPF",$JOB,PG,MK,IT,I)=NN_U_CS
+6 if 'RMPFIT
GOTO U2
PRINT SET (CT,PG)=0
PG SET PG=$ORDER(^TMP("RMPF",$JOB,PG))
if PG=""
GOTO EXIT
+1 SET X=$ORDER(^RMPF(791811.1,"B",PG,0))
SET PP=0
+2 IF X
IF $DATA(^RMPF(791811.1,X,0))
SET PP=$PIECE(^(0),U,2)
IT SET MK=-1
SET PP=$SELECT(PP="CHA"!(PP="SHA")!(PP="ALD"):0,1:1)
DO HEAD
+1 DO @("HEAD"_PP)
IT1 SET MK=$ORDER(^TMP("RMPF",$JOB,PG,MK))
IF MK=""
if IOST?1"C-".E
DO CONT
GOTO PG
+1 SET IT=0
IT2 SET IT=$ORDER(^TMP("RMPF",$JOB,PG,MK,IT))
if IT=""
GOTO IT1
SET DA=0
IT3 SET DA=$ORDER(^TMP("RMPF",$JOB,PG,MK,IT,DA))
if 'DA
GOTO IT2
if DA=1
GOTO IT3
+1 if '$DATA(^RMPF(791811,DA,0))
GOTO IT3
SET S0=^(0)
IF $DATA(^("I"))
IF $PIECE(^("I"),U)
GOTO IT3
+2 SET CS=$PIECE(S0,U,4)
SET MR=$PIECE(S0,U,6)
SET UI=$PIECE(S0,U,8)
SET NN=$PIECE(S0,U,5)
if 'UI
SET UI=1
+3 ;I MR S CS=CS*(1+(MR*.01))
SET AM=$PIECE(S0,U,9)
+4 IF $Y>(IOSL-3)
IF IOST?1"C-".E
DO CRT
if $DATA(RMPFOUT)
GOTO END
+5 IF $Y>58
IF IOST?1"P-".E
DO PRT
+6 IF 'PP
DO AIDS
if $DATA(RMPFOUT)
GOTO END
if 'RMPFIT
GOTO IT3
GOTO EXIT
+7 WRITE !!,$EXTRACT(IT,1,30),?33,$JUSTIFY(CS,8,2),?43,$JUSTIFY(UI,7,0),?58,NN,?76,AM
SET CT=CT+1
+8 if 'RMPFIT
GOTO IT3
EXIT WRITE !!,"Total Items Printed: ",CT
if IOST?1"P-".E
WRITE @IOF
+1 if $DATA(IO("S"))
DO ^%ZISC
END KILL B,BP,BT,C,C1,CM,CP,CS,CT,DA,DP,I,IT,MK,NN,PA,PG,S0,P,Y,^TMP("RMPF",$JOB)
+1 KILL RMPFBT,RMPFCM,RMPFIT,RMPFOUT,RMPFPG,RMPFQUT,PP,UI,X,POP,MR,CD,AM
QUIT
AIDS DO WRITE
SET (CM,BT)=0
SET CT=CT+1
KILL RMPFBT,RMPFCM
+1 FOR I=1:1
SET BT=$ORDER(^RMPF(791811,DA,102,BT))
if 'BT
QUIT
IF $DATA(^(BT,0))
SET B=$PIECE(^(0),U,1)
IF B
IF $DATA(^RMPF(791811.3,B,0))
SET BP=$PIECE(^(0),U,1)
SET RMPFBT(BP)=""
+2 FOR I=1:1
SET CM=$ORDER(^RMPF(791811,DA,101,CM))
if 'CM
QUIT
IF $DATA(^(CM,0))
SET C=$PIECE(^(0),U,1)
IF C
IF $DATA(^RMPF(791811.2,C,0))
SET CP=$PIECE(^(0),U,1)
SET CD=$PIECE(^(0),U,3)
IF CP'=""
SET RMPFCM(CP)=$PIECE(^RMPF(791811,DA,101,CM,0),U,2)_U_CD
+3 SET (BT,CM)=0
+4 FOR I=1:1
if '$DATA(RMPFCM)&'$DATA(RMPFBT)
QUIT
Begin DoDot:1
+5 if C1
WRITE !
SET C1=C1+1
+6 SET BT=$ORDER(RMPFCM(BT))
+7 IF BT'=""
SET (X,S)=$PIECE(RMPFCM(BT),U,1)
if MR="TAKE THIS OUT"
SET S=X*(1+(MR*.01))
WRITE ?37,$EXTRACT(BT,1,19),?58,$EXTRACT($PIECE(RMPFCM(BT),U,2),1,8),?68,$JUSTIFY(S,5,2)
KILL RMPFCM(BT)
+8 SET CM=$ORDER(RMPFBT(CM))
IF CM'=""
WRITE ?75,$EXTRACT(CM,1,8)
KILL RMPFBT(CM)
+9 IF $Y>21
IF IOST?1"C-".E
DO CRT
if $DATA(RMPFOUT)
QUIT
DO WRITE
+10 IF $Y>58
IF IOST?1"P-".E
DO PRT
+11 QUIT
End DoDot:1
if $DATA(RMPFOUT)
QUIT
+12 QUIT
WRITE WRITE !!,$EXTRACT(IT,1,16),?18,$EXTRACT(MK,1,9),?29,$JUSTIFY(CS,6,2)
SET C1=0
QUIT
CONT FOR
if $Y>22
QUIT
WRITE !
+1 WRITE !,"Enter <RETURN> to continue."
DO READ
if $DATA(RMPFOUT)
QUIT
+2 IF $DATA(RMPFQUT)
WRITE !!,"Enter a <RETURN> to continue viewing or an <^> to exit."
GOTO CONT
+3 if Y=""
QUIT
GOTO CONT
QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
CRT DO CONT
if $DATA(RMPFOUT)
QUIT
DO HEAD
DO @("HEAD"_PP)
WRITE !,"cont."
QUIT
PRT DO HEAD
DO @("HEAD"_PP)
WRITE !,"cont."
QUIT
HEAD WRITE @IOF,!?27,"REMOTE ORDER/ENTRY SYSTEM",?72,"page: ",PA
SET PA=PA+1
+1 WRITE !?32,"PRODUCT LISTING"
+2 WRITE !!,"Product Group: ",PG,?56,"Print Date: ",DP
+3 WRITE !
FOR I=1:1:80
WRITE "-"
+4 QUIT
HEAD0 WRITE !?5,"Model",?20,"Make",?29,"Price",?42,"Component",?60,"Code"
+1 WRITE ?68,"Price",?75,"Batt."
+2 WRITE !,"----------------",?18,"---------",?29,"------",?37,"-------------------",?58,"--------"
+3 WRITE ?68,"-----",?75,"-----"
+4 QUIT
HEAD1 WRITE !?13,"Item",?35,"Price",?43,"Unit of Issue",?64,"NSN",?76,"AMIS"
+1 WRITE !,"-------------------------------",?33,"--------",?43,"-------------",?58,"----------------",?76,"----"
+2 QUIT
