source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRESI.m@ 1697

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1RMPRESI ;PHX/JLT-ENTER/EDIT SITE PARAMETERS ROUTINE ;8/29/1994
2 ;;3.0;PROSTHETICS;**51,55,62,90**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - 1/29/01 - Add prompt for field 34 in 669.9
5 ; mail routing code (see AUG-1097-32118)
6 ;
7 ; RVD patch #62 - added PCE Hospital Location prompt
8 ;
9DIR K Y,DA,DIR S DIR(0)="FO^3:30",DIR("?")="^S X=""?"" D INS^RMPRESI",DIR("A")="Select PROSTHETICS SITE PARAMETER SITE NAME" D ^DIR G:$D(DIRUT)!$D(DTOUT) EXIT
10 S DIC=669.9,DIC(0)="EMZ",RMPRX=X D ^DIC I +Y>0 S RMPRIEN=+Y G EDIT
11 S X=RMPRX,DIC=4,DIC(0)="EQMZ" D ^DIC G:+Y'>0 DIR S SITE=+Y
12START S RMPRA=^DIC(4,SITE,0),RMPRB=$S($D(^DIC(4,SITE,1)):^(1),1:" "),SIG="",ST=$P(^DIC(4,SITE,0),U,2)
13 S DIC=669.9,DIC(0)="EQZL",DLAYGO=669.9,X=$P($P(RMPRA,","),U)_" VAMC",DIC("DR")="1////^S X=SITE" D ^DIC K DLAYGO G:+Y'>0 DIR S RMPRIEN=+Y
14 S STRT=$P(RMPRB,U,1)
15 S CITY=$P(RMPRB,U,3),RIP=$P(RMPRB,U,4),ART=125,WCHR=100,BRSS=75,BAS=75,PG=90,COP=90,CDP=90
16CON S RMPRSITE=$O(^RMPR(669.9,0)),AIN=$P(^RMPR(669.9,RMPRSITE,0),U,3) I $D(^(2)) S SIG=$P(^(2),U,6),SBT=$P(^(2),U,1)
17 S DA=RMPRIEN,DIE="^RMPR(669.9,"
18 S DR="2////^S X=AIN;4////^S X=STRT;5////^S X=CITY;6////^S X=ST;7////^S X=RIP;8////^S X=SIG;8.5///^S X=SBT;11////^S X=99999999;15////^S X=ART;16////^S X=WCHR;17////^S X=BRSS;18////^S X=BAS;19////^S X=PG;20////^S X=COP;21////^S X=CDP" D ^DIE
19EDIT ;EDIT SITE PARAMENTERS
20 ; Added fields 8.1 and 10 in patch 90
21 S DIE="^RMPR(669.9,",DA=RMPRIEN,DR=".01;40;3;4;5;6;7;7.1;8;8.1;10;8.5;2;31;32;33;34;9;27;28;29;30;19;20;21;15;16;17;18;22;52" D ^DIE G DIR
22EXIT N RMPRSITE,RMPR D KILL^XUSCLEAN Q
23INS S RI="" F S RI=$O(^RMPR(669.9,"B",RI)) Q:RI="" S RRMPR=$O(^RMPR(669.9,"B",RI,0)),RRMPR=^RMPR(669.9,RRMPR,0) W !,?5,$P(RRMPR,U)," ",?50,$P(^DIC(4,$P(RRMPR,U,2),99),U)
24 S DIC=4,DIC(0)="EQMZ" D ^DIC Q
25 ;
26 Q
27A1 G A2
28MGR(RESULTS) ;RPC to display manger comment
29A2 ;
30 S RMPRS=0,RESULTS(0)=""
31 F S RMPRS=$O(^RMPR(669.9,RMPRS)) Q:RMPRS="" D
32 .S RESULTS(0)=RESULTS(0)_" "_$P($G(^RMPR(669.9,RMPRS,6)),U,1)
33 K RMPRS
34 Q
Note: See TracBrowser for help on using the repository browser.