RMPRHISL ;PHX/RFM-HISTORICAL DATA ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
;QTY&COST
NEX ;CONTINUATION OF HISTORICAL DATA ROUTING RMPRHIS
K DIR,DIRUT I $P(R1(0),U,14)="C" S DIR(0)="667.3,3",DIR("A")="UNIT COST" S:$P(R1(0),U,16) DIR("B")=$P(R1(0),U,16)/$P(R1(0),U,7) D ^DIR I $P(R1(0),U,16)'=""&$D(DUOUT) K DIR G LIST
X:$D(DIRUT) CK Q:'$D(R1(0)) S $P(R1(0),U,16)=Y,$P(R3("D"),U,16)=Y K DIR
I $P(R1(0),U,14)="V" S $P(R1(0),U,16)=0
S DIR(0)="660,5" S:$P(R1(0),U,7) DIR("B")=$P(R1(0),U,7) D ^DIR I $P(R1(0),U,7)'=""&$D(DUOUT) K DIR G LIST
X:$D(DIRUT) CK Q:'$D(R1(0)) S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*$P(R1(0),U,16) K DIR
;
DATE S:$P(R1(0),U,12) %DT("B")=$P(R3("D"),U,12) S %DT("A")="DELIVERY DATE: ",%DT="AEXP" D ^%DT G:X="" LI S:Y>0 $P(R1(0),U,12)=Y G:X["^"&($P(R3("D"),U,12)'="") LIST G:X["^" LI D DD^%DT S $P(R3("D"),U,12)=Y
;
LI S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DTOUT) EXIT G:$D(DUOUT) LIST I X["^" W !,"Jumping not allowed!" G LI
S $P(R1(0),U,11)=X
I $P(R1(0),U,11)'=""&(X="@") S $P(R1(0),U,11)="" W !?5,"Deleted..." H 1
LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)?.E&($P(R1(0),U,24)'="") DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DTOUT) EXIT G:$D(DUOUT) LIST I X["^" W !,"Jumping not allowed!" G LOT
S $P(R1(0),U,24)=X
I $P(R1(0),U,24)'=""&(X="@") S $P(R1(0),U,24)="" W !?5,"Deleted..." H 1
SER K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)?.E&($P(R1(0),U,18)'="") DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DTOUT) EXIT G:$D(DUOUT) LIST I X["^" W !,"Jumping not allowed!" G SER
S $P(R1(0),U,18)=X
I $P(R1(0),U,18)'=""&(X="@") S $P(R1(0),U,18)="" W !?5,"Deleted..." H 1
LIST ;SCREEN DISPLAY OF COMPLETED ITEM TRANSACTION
K DIR D ^RMPRST2
S %=1 R !,"Do you wish to POST this entry" D YN^DICN G:%<0 EXIT G:%=1 POST
S %=2 R !,"Do you wish to Delete this entry" D YN^DICN G:$D(DTOUT) EXIT G:%=1 RES^RMPRHIS G:%=2 1^RMPRHIS
POST K Y,DD,DO S DIC="^RMPR(660,",DIC(0)="L",DLAYGO=660,X=DT D FILE^DICN K DLAYGO S ^RMPR(660,+Y,0)=R1(0),^("AM")=R1("AM"),DIK="^RMPR(660,",DA=+Y D IX1^DIK K DIC G RES^RMPRHIS
;
EXIT ;KILL VARIABLES AND EXIT HISTORICAL DATA
K DIE,RMPRGIP,PRCP,J,%,X,DA,Y,CK,DIR,DIRUT,RMPRG,DIK,DIC,%DT,DUOUT,DTOUT,RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,RMPRHISD,R1,R3,R4,RMPRF,HL,RMPRKILL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRHISL 2268 printed Nov 22, 2024@17:44:53 Page 2
RMPRHISL ;PHX/RFM-HISTORICAL DATA ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
+2 ;QTY&COST
NEX ;CONTINUATION OF HISTORICAL DATA ROUTING RMPRHIS
+1 KILL DIR,DIRUT
IF $PIECE(R1(0),U,14)="C"
SET DIR(0)="667.3,3"
SET DIR("A")="UNIT COST"
if $PIECE(R1(0),U,16)
SET DIR("B")=$PIECE(R1(0),U,16)/$PIECE(R1(0),U,7)
DO ^DIR
IF $PIECE(R1(0),U,16)'=""&$DATA(DUOUT)
KILL DIR
GOTO LIST
+2 if $DATA(DIRUT)
XECUTE CK
if '$DATA(R1(0))
QUIT
SET $PIECE(R1(0),U,16)=Y
SET $PIECE(R3("D"),U,16)=Y
KILL DIR
+3 IF $PIECE(R1(0),U,14)="V"
SET $PIECE(R1(0),U,16)=0
+4 SET DIR(0)="660,5"
if $PIECE(R1(0),U,7)
SET DIR("B")=$PIECE(R1(0),U,7)
DO ^DIR
IF $PIECE(R1(0),U,7)'=""&$DATA(DUOUT)
KILL DIR
GOTO LIST
+5 if $DATA(DIRUT)
XECUTE CK
if '$DATA(R1(0))
QUIT
SET $PIECE(R1(0),U,7)=Y
SET $PIECE(R1(0),U,16)=Y*$PIECE(R1(0),U,16)
KILL DIR
+6 ;
DATE if $PIECE(R1(0),U,12)
SET %DT("B")=$PIECE(R3("D"),U,12)
SET %DT("A")="DELIVERY DATE: "
SET %DT="AEXP"
DO ^%DT
if X=""
GOTO LI
if Y>0
SET $PIECE(R1(0),U,12)=Y
if X["^"&($PIECE(R3("D"),U,12)'="")
GOTO LIST
if X["^"
GOTO LI
DO DD^%DT
SET $PIECE(R3("D"),U,12)=Y
+1 ;
LI SET DIR(0)="660,9"
if $PIECE(R1(0),U,11)'=""
SET DIR("B")=$PIECE(R1(0),U,11)
DO ^DIR
if $DATA(DTOUT)
GOTO EXIT
if $DATA(DUOUT)
GOTO LIST
IF X["^"
WRITE !,"Jumping not allowed!"
GOTO LI
+1 SET $PIECE(R1(0),U,11)=X
+2 IF $PIECE(R1(0),U,11)'=""&(X="@")
SET $PIECE(R1(0),U,11)=""
WRITE !?5,"Deleted..."
HANG 1
LOT KILL DIR
SET DIR(0)="660,21"
if $PIECE(R1(0),U,24)?.E&($PIECE(R1(0),U,24)'="")
SET DIR("B")=$PIECE(R1(0),U,24)
DO ^DIR
if $DATA(DTOUT)
GOTO EXIT
if $DATA(DUOUT)
GOTO LIST
IF X["^"
WRITE !,"Jumping not allowed!"
GOTO LOT
+1 SET $PIECE(R1(0),U,24)=X
+2 IF $PIECE(R1(0),U,24)'=""&(X="@")
SET $PIECE(R1(0),U,24)=""
WRITE !?5,"Deleted..."
HANG 1
SER KILL DIR
SET DIR(0)="660,16"
if $PIECE(R1(0),U,18)?.E&($PIECE(R1(0),U,18)'="")
SET DIR("B")=$PIECE(R1(0),U,18)
DO ^DIR
if $DATA(DTOUT)
GOTO EXIT
if $DATA(DUOUT)
GOTO LIST
IF X["^"
WRITE !,"Jumping not allowed!"
GOTO SER
+1 SET $PIECE(R1(0),U,18)=X
+2 IF $PIECE(R1(0),U,18)'=""&(X="@")
SET $PIECE(R1(0),U,18)=""
WRITE !?5,"Deleted..."
HANG 1
LIST ;SCREEN DISPLAY OF COMPLETED ITEM TRANSACTION
+1 KILL DIR
DO ^RMPRST2
+2 SET %=1
READ !,"Do you wish to POST this entry"
DO YN^DICN
if %<0
GOTO EXIT
if %=1
GOTO POST
+3 SET %=2
READ !,"Do you wish to Delete this entry"
DO YN^DICN
if $DATA(DTOUT)
GOTO EXIT
if %=1
GOTO RES^RMPRHIS
if %=2
GOTO 1^RMPRHIS
POST KILL Y,DD,DO
SET DIC="^RMPR(660,"
SET DIC(0)="L"
SET DLAYGO=660
SET X=DT
DO FILE^DICN
KILL DLAYGO
SET ^RMPR(660,+Y,0)=R1(0)
SET ^("AM")=R1("AM")
SET DIK="^RMPR(660,"
SET DA=+Y
DO IX1^DIK
KILL DIC
GOTO RES^RMPRHIS
+1 ;
EXIT ;KILL VARIABLES AND EXIT HISTORICAL DATA
+1 KILL DIE,RMPRGIP,PRCP,J,%,X,DA,Y,CK,DIR,DIRUT,RMPRG,DIK,DIC,%DT,DUOUT,DTOUT,RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,RMPRHISD,R1,R3,R4,RMPRF,HL,RMPRKILL
+2 QUIT
