- 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 Apr 23, 2025@18:49:21 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
