source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRHIS.m@ 1765

Last change on this file since 1765 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1RMPRHIS ;PHX/RFM-ADD HISTORICAL DATA ;8/29/1994
2 ;;3.0;PROSTHETICS;**19,45,90**;Feb 09, 1996
3 K RMPRDFN,RMPRSSN,RMPRNAM,RMPRDOB,DIR D HOME^%ZIS S RMPRF=""
4 W @IOF D DIV4^RMPRSIT G:$D(X) EXIT^RMPRHISL D:'$D(RMPRHIS) GETPAT^RMPRUTIL G:'$D(RMPRDFN) EXIT^RMPRHISL
5VIEW D ^RMPRPAT I $D(RMPRKILL) W !,$C(7),"Deleted..." G EXIT^RMPRHISL
6RES ;ADDS ANOTHER ITEM FOR HISTORICAL DATA
7 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"
8 K R1,DA,DD,DIC,PRC,X,Y
9 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")=""
10 ;DISPLAY VARIABLE
11 S (R3("D"),R4("D"))="",RMPRHISD=1
121 ;ENTRY POINT TO EDIT AN ITEM
13 W @IOF
14 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
15 S:Y>0 $P(R1(0),U,3)=Y D DD^%DT S $P(R3("D"),U,3)=Y
16 S DIR("?")="Enter V for VA or C for Commercial"
17LI S DIR(0)="SBO^V:VA;C:COMMERCIAL"
18 S DIR("A")="Select VA or COMMERCIAL SOURCE"
19 S:$P(R3("D"),U,14)?.A&($P(R3("D"),U,14)'="") DIR("B")=$P(R3("D"),U,14)
20 D ^DIR
21 I $P(R3("D"),U,14)?1A.A&($D(DUOUT)) K DIR G LIST^RMPRHISL
22 G:$D(DTOUT) EXIT^RMPRHISL
23 G:X=""!($D(DUOUT)) ^RMPRHIS
24 G:$D(DIRUT) EXIT^RMPRHISL S $P(R1(0),U,14)=Y K DIR
25 S $P(R3("D"),U,14)=$S(Y="C":"COMMERCIAL",Y="V":"VA",1:"")
262 ;
27 S DIC=661,DIC(0)="AEQM",DIC("A")="ITEM: "
28 S:$P(R1(0),U,6) DIC("B")=$P(R1(0),U,6)
29 D ^DIC
30 I $P(R3("D"),U,6)'=""&$D(DUOUT) K DIC G LIST^RMPRHISL
31 X:$D(DUOUT) CK Q:'$D(R1(0))
32 G:(+Y'>0)&($D(DTOUT)) EXIT^RMPRHISL
33 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G 2
34 S $P(R1(0),U,6)=+Y,$P(R3("D"),U,6)=$P(Y,U,2) K DIC
35V ;
36 S DIC=440,DIC(0)="AEQM",DIC("A")="VENDOR: "
37 S:$P(R1(0),U,9) DIC("B")=$P(R1(0),U,9)
38 D ^DIC
39 I $P(R3("D"),U,9)'=""&$D(DUOUT) K DIC G LIST^RMPRHISL
40 X:$D(DUOUT) CK Q:'$D(R1(0))
41 G:(+Y'>0)&($D(DTOUT)) EXIT^RMPRHISL
42 I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G V
43 S $P(R1(0),U,9)=+Y,$P(R3("D"),U,9)=$P(Y,U,2) K DIC
44 W ! S DIR(0)="660,2"
45 S:$P(R1(0),U,4)?.E&($P(R3("D"),U,4)'="") DIR("B")=$P(R3("D"),U,4)
46 D ^DIR
47 I $P(R3("D"),U,4)'=""&($D(DUOUT)) K DIR G LIST^RMPRHISL
48 X:$D(DIRUT) CK Q:'$D(R1(0)) S $P(R1(0),U,4)=Y K DIR
49 S $P(R3("D"),U,4)=$S(Y="I":"INITIAL ISSUE",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",Y=5:"RENTAL",1:"")
50 S DIR(0)="660,62"
51 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))
52 S $P(R1("AM"),U,3)=Y
53 S $P(R4("D"),U,3)=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"")
54 K DIR
55 I Y<4 S $P(R1("AM"),U,4)="",$P(R4("D"),U,4)="" G ^RMPRHISL
56 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
57 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
Note: See TracBrowser for help on using the repository browser.