RMPRHIS ;PHX/RFM-ADD HISTORICAL DATA ;8/29/1994
;;3.0;PROSTHETICS;**19,45,90**;Feb 09, 1996
K RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,DIR D HOME^%ZIS S RMPRF=""
W @IOF D DIV4^RMPRSIT G:$D(X) EXIT^RMPRHISL D:'$D(RMPRHIS) GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRHISL
VIEW D ^RMPRPAT I $D(RMPRKILL) W !,$C(7),"Deleted..." G EXIT^RMPRHISL
RES ;ADDS ANOTHER ITEM FOR HISTORICAL DATA
S CK="W:$D(DUOUT) @IOF,$C(7),!!?28,""Deleted..."" H 3 W:$D(DUOUT) @IOF G:$D(DUOUT) RES^RMPRHIS G:$D(DIRUT) EXIT^RMPRHISL"
K R1,DA,DD,DIC,PRC,X,Y
S R1(0)=DT_U_RMPRDFN,$P(R1(0),U,10)=RMPR("STA"),$P(R1(0),U,15)="*",$P(R1(0),U,13)=13,$P(R1(0),U,27)=DUZ,R1("AM")=""
;DISPLAY VARIABLE
S (R3("D"),R4("D"))="",RMPRHISD=1
1 ;ENTRY POINT TO EDIT AN ITEM
W @IOF
W !?30,RMPRNAM,! S:$P(R1(0),U,3) %DT("B")=$P(R3("D"),U,3) S %DT("A")="DATE OF REQUEST: ",%DT="AEXP" D ^%DT G:X="" ^RMPRHIS G:X="^"&$P(R3("D"),U,3) LIST^RMPRHISL G:X="^" EXIT^RMPRHISL
S:Y>0 $P(R1(0),U,3)=Y D DD^%DT S $P(R3("D"),U,3)=Y
S DIR("?")="Enter V for VA or C for Commercial"
LI S DIR(0)="SBO^V:VA;C:COMMERCIAL"
S DIR("A")="Select VA or COMMERCIAL SOURCE"
S:$P(R3("D"),U,14)?.A&($P(R3("D"),U,14)'="") DIR("B")=$P(R3("D"),U,14)
D ^DIR
I $P(R3("D"),U,14)?1A.A&($D(DUOUT)) K DIR G LIST^RMPRHISL
G:$D(DTOUT) EXIT^RMPRHISL
G:X=""!($D(DUOUT)) ^RMPRHIS
G:$D(DIRUT) EXIT^RMPRHISL S $P(R1(0),U,14)=Y K DIR
S $P(R3("D"),U,14)=$S(Y="C":"COMMERCIAL",Y="V":"VA",1:"")
2 ;
S DIC=661,DIC(0)="AEQM",DIC("A")="ITEM: "
S:$P(R1(0),U,6) DIC("B")=$P(R1(0),U,6)
D ^DIC
I $P(R3("D"),U,6)'=""&$D(DUOUT) K DIC G LIST^RMPRHISL
X:$D(DUOUT) CK Q:'$D(R1(0))
G:(+Y'>0)&($D(DTOUT)) EXIT^RMPRHISL
I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G 2
S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) K DIC
V ;
S DIC=440,DIC(0)="AEQM",DIC("A")="VENDOR: "
S:$P(R1(0),U,9) DIC("B")=$P(R1(0),U,9)
D ^DIC
I $P(R3("D"),U,9)'=""&$D(DUOUT) K DIC G LIST^RMPRHISL
X:$D(DUOUT) CK Q:'$D(R1(0))
G:(+Y'>0)&($D(DTOUT)) EXIT^RMPRHISL
I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G V
S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC
W ! S DIR(0)="660,2"
S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4)
D ^DIR
I $P(R3("D"),U,4)'=""&($D(DUOUT)) K DIR G LIST^RMPRHISL
X:$D(DIRUT) CK Q:'$D(R1(0)) S $P(R1(0),U,4)=Y K DIR
S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",Y=5:"RENTAL",1:"")
S DIR(0)="660,62"
S:$P(R1("AM"),U,3)?1N.N DIR("B")=$P(R4("D"),U,3) D ^DIR G:$P(R1("AM"),U,3)'=""&($D(DUOUT)) LIST^RMPRHISL X:$D(DIRUT) CK Q:'$D(R1(0))
S $P(R1("AM"),U,3)=Y
S $P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
K DIR
I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G ^RMPRHISL
I Y=4 S DIR(0)="660,63" S:$P(R1("AM"),U,4)?1N.N DIR("B")=$P(R4("D"),U,4) D ^DIR G:X="" NEX^RMPRHISL I $D(DUOUT)&($P(R1(0),U,7)) K DIR G LIST^RMPRHISL G:$D(DIRUT) EXIT^RMPRHISL
I $P(R1("AM"),U,3)=4 S $P(R1("AM"),U,4)=Y,$P(R4("D"),U,4)=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"") G ^RMPRHISL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRHIS 3119 printed Nov 22, 2024@17:44:51 Page 2
RMPRHIS ;PHX/RFM-ADD HISTORICAL DATA ;8/29/1994
+1 ;;3.0;PROSTHETICS;**19,45,90**;Feb 09, 1996
+2 KILL RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,DIR
DO HOME^%ZIS
SET RMPRF=""
+3 WRITE @IOF
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT^RMPRHISL
if '$DATA(RMPRHIS)
DO GETPAT^RMPRUTIL
if '$DATA(RMPRDFN)
GOTO EXIT^RMPRHISL
VIEW DO ^RMPRPAT
IF $DATA(RMPRKILL)
WRITE !,$CHAR(7),"Deleted..."
GOTO EXIT^RMPRHISL
RES ;ADDS ANOTHER ITEM FOR HISTORICAL DATA
+1 SET CK="W:$D(DUOUT) @IOF,$C(7),!!?28,""Deleted..."" H 3 W:$D(DUOUT) @IOF G:$D(DUOUT) RES^RMPRHIS G:$D(DIRUT) EXIT^RMPRHISL"
+2 KILL R1,DA,DD,DIC,PRC,X,Y
+3 SET R1(0)=DT_U_RMPRDFN
SET $PIECE(R1(0),U,10)=RMPR("STA")
SET $PIECE(R1(0),U,15)="*"
SET $PIECE(R1(0),U,13)=13
SET $PIECE(R1(0),U,27)=DUZ
SET R1("AM")=""
+4 ;DISPLAY VARIABLE
+5 SET (R3("D"),R4("D"))=""
SET RMPRHISD=1
1 ;ENTRY POINT TO EDIT AN ITEM
+1 WRITE @IOF
+2 WRITE !?30,RMPRNAM,!
if $PIECE(R1(0),U,3)
SET %DT("B")=$PIECE(R3("D"),U,3)
SET %DT("A")="DATE OF REQUEST: "
SET %DT="AEXP"
DO ^%DT
if X=""
GOTO ^RMPRHIS
if X="^"&$PIECE(R3("D"),U,3)
GOTO LIST^RMPRHISL
if X="^"
GOTO EXIT^RMPRHISL
+3 if Y>0
SET $PIECE(R1(0),U,3)=Y
DO DD^%DT
SET $PIECE(R3("D"),U,3)=Y
+4 SET DIR("?")="Enter V for VA or C for Commercial"
LI SET DIR(0)="SBO^V:VA;C:COMMERCIAL"
+1 SET DIR("A")="Select VA or COMMERCIAL SOURCE"
+2 if $PIECE(R3("D"),U,14)?.A&($PIECE(R3("D"),U,14)'="")
SET DIR("B")=$PIECE(R3("D"),U,14)
+3 DO ^DIR
+4 IF $PIECE(R3("D"),U,14)?1A.A&($DATA(DUOUT))
KILL DIR
GOTO LIST^RMPRHISL
+5 if $DATA(DTOUT)
GOTO EXIT^RMPRHISL
+6 if X=""!($DATA(DUOUT))
GOTO ^RMPRHIS
+7 if $DATA(DIRUT)
GOTO EXIT^RMPRHISL
SET $PIECE(R1(0),U,14)=Y
KILL DIR
+8 SET $PIECE(R3("D"),U,14)=$SELECT(Y="C":"COMMERCIAL",Y="V":"VA",1:"")
2 ;
+1 SET DIC=661
SET DIC(0)="AEQM"
SET DIC("A")="ITEM: "
+2 if $PIECE(R1(0),U,6)
SET DIC("B")=$PIECE(R1(0),U,6)
+3 DO ^DIC
+4 IF $PIECE(R3("D"),U,6)'=""&$DATA(DUOUT)
KILL DIC
GOTO LIST^RMPRHISL
+5 if $DATA(DUOUT)
XECUTE CK
if '$DATA(R1(0))
QUIT
+6 if (+Y'>0)&($DATA(DTOUT))
GOTO EXIT^RMPRHISL
+7 IF +Y'>0
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
GOTO 2
+8 SET $PIECE(R1(0),U,6)=+Y
SET $PIECE(R3("D"),U,6)=$PIECE(Y,U,2)
KILL DIC
V ;
+1 SET DIC=440
SET DIC(0)="AEQM"
SET DIC("A")="VENDOR: "
+2 if $PIECE(R1(0),U,9)
SET DIC("B")=$PIECE(R1(0),U,9)
+3 DO ^DIC
+4 IF $PIECE(R3("D"),U,9)'=""&$DATA(DUOUT)
KILL DIC
GOTO LIST^RMPRHISL
+5 if $DATA(DUOUT)
XECUTE CK
if '$DATA(R1(0))
QUIT
+6 if (+Y'>0)&($DATA(DTOUT))
GOTO EXIT^RMPRHISL
+7 IF +Y'>0
WRITE !!,?5,$CHAR(7),"This is a required response. Enter '^' to exit",!
GOTO V
+8 SET $PIECE(R1(0),U,9)=+Y
SET $PIECE(R3("D"),U,9)=$PIECE(Y,U,2)
KILL DIC
+9 WRITE !
SET DIR(0)="660,2"
+10 if $PIECE(R1(0),U,4)?.E&($PIECE(R3("D"),U,4)'="")
SET DIR("B")=$PIECE(R3("D"),U,4)
+11 DO ^DIR
+12 IF $PIECE(R3("D"),U,4)'=""&($DATA(DUOUT))
KILL DIR
GOTO LIST^RMPRHISL
+13 if $DATA(DIRUT)
XECUTE CK
if '$DATA(R1(0))
QUIT
SET $PIECE(R1(0),U,4)=Y
KILL DIR
+14 SET $PIECE(R3("D"),U,4)=$SELECT(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",Y=5:"RENTAL",1:"")
+15 SET DIR(0)="660,62"
+16 if $PIECE(R1("AM"),U,3)?1N.N
SET DIR("B")=$PIECE(R4("D"),U,3)
DO ^DIR
if $PIECE(R1("AM"),U,3)'=""&($DATA(DUOUT))
GOTO LIST^RMPRHISL
if $DATA(DIRUT)
XECUTE CK
if '$DATA(R1(0))
QUIT
+17 SET $PIECE(R1("AM"),U,3)=Y
+18 SET $PIECE(R4("D"),U,3)=$SELECT(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
+19 KILL DIR
+20 IF Y<4
SET $PIECE(R1("AM"),U,4)=""
SET $PIECE(R4("D"),U,4)=""
GOTO ^RMPRHISL
+21 IF Y=4
SET DIR(0)="660,63"
if $PIECE(R1("AM"),U,4)?1N.N
SET DIR("B")=$PIECE(R4("D"),U,4)
DO ^DIR
if X=""
GOTO NEX^RMPRHISL
IF $DATA(DUOUT)&($PIECE(R1(0),U,7))
KILL DIR
GOTO LIST^RMPRHISL
if $DATA(DIRUT)
GOTO EXIT^RMPRHISL
+22 IF $PIECE(R1("AM"),U,3)=4
SET $PIECE(R1("AM"),U,4)=Y
SET $PIECE(R4("D"),U,4)=$SELECT(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
GOTO ^RMPRHISL
