- 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 Mar 13, 2025@21:41:52 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
