source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOL.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1RMPREOL ;HINES/RVD SUSPENSE PROCESSING/LINK TO 2319 ; 14-AUG-2001
2 ;;3.0;PROSTHETICS;**62**;Feb 09, 1996
3 ;
4 ; RVD patch #62 - new routine for suspense list template.
5 ; if link to 2319 record is needed.
6EN ; -- main entry point for RMPREO
7 D ^%ZISC
8 N STRING,CLREND,COLUMN,LINE,ON,OFF
9 ;get patient to test with
10 K ^TMP($J,"RMPREO")
11 K ^TMP($J,"RMPREOEE")
12 ;ask station
13 I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
14 I '$D(RMPRDFN) D GETPAT^RMPRUTIL Q:'$D(RMPRDFN)
15 D EN^VALM("RMPREO LINK 2319")
16 Q
17 ;
18HDR ; -- header code
19 N VA,VADM
20 S DFN=RMPRDFN
21 D DEM^VADPT
22 ;S VALMHDR(1)="Suspense Processing"
23 S VALMHDR(1)="Open/Pending/Closed Suspense for "_$$LOWER^VALM1(VADM(1))_" ("_$P(VADM(2),U,2)_")"
24 D KVAR^VADPT
25 K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
26 Q
27 ;
28INIT ; -- init variables and list array
29 K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
30 D HDR
31 N RMPRA,CDATE,LINE,X
32 ;start loop
33 ;
34 K ADATE,PDAY
35 S RMPRA="",VALMCNT=0,RRX=""
36 ;reverse order display
37 F S RMPRA=$O(^RMPR(668,"C",RMPRDFN,RMPRA),-1) Q:RMPRA="" D
38 .I $P(^RMPR(668,RMPRA,0),U,10)="X" Q
39 .I $G(RMSUCLFG),'$D(RM68LINK(RMPRA)) Q
40 .S VALMCNT=VALMCNT+1,LINE=VALMCNT
41 .S RRX=$$SETFLD^VALM1(LINE,RRX,"LINE")
42 .S CDATE=$P(^RMPR(668,RMPRA,0),U,1),CDATE=$$DAT1^RMPRUTL1(CDATE)
43 .S RRX=$$SETFLD^VALM1(CDATE,RRX,"DATE")
44 .S WHO1=""
45 .I $P(^RMPR(668,RMPRA,0),U,11)'="" S WHO1=$$WHO^RMPREOU($P(^RMPR(668,RMPRA,0),U,11),12)
46 .;I WHO1'="" S RRX=$$SETFLD^VALM1(WHO1,RRX,"WHO")
47 .S RRX=$$SETFLD^VALM1(WHO1,RRX,"WHO")
48 .K WHO,WHO1
49 .;type
50 .S TYPE=$$TYPE^RMPREOU(RMPRA,8)
51 .S RRX=$$SETFLD^VALM1(TYPE,RRX,"TYPE")
52 .;display description if manual
53 .;
54 .S RRX=$$SETFLD^VALM1($$DES^RMPREOU(RMPRA,22),RRX,"DES")
55 .;init activation date
56 .S ADATE="",PDAY="",WRKDAY=""
57 .S ADATE=$P(^RMPR(668,RMPRA,0),U,9)
58 .I ADATE'="" S (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA)
59 .I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA)
60 .S RRX=$$SETFLD^VALM1($$DAT1^RMPRUTL1(ADATE),RRX,"INITIAL ACTION DATE")
61 .I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA) I CDAY>7 S PDAY="*"_WRKDAY
62 .I ADATE=""&(WRKDAY>5) S PDAY="@"_WRKDAY
63 .S RRX=$$SETFLD^VALM1(PDAY,RRX,"PDAY")
64 .K ADATE,PDAY,WRKDAY,CDAY
65 .;S R660=""
66 .;F S R660=$O(^RMPR(668,RMPRA,6,"B",R660)) Q:R660'>0 D
67 .; .S RRX=$$SETFLD^VALM1($$ITEM^RMPREOU(R660,17),RRX,"ITEM")
68 .S RRX=$$SETFLD^VALM1($$STATUS^RMPREOU(RMPRA,7),RRX,"STATUS")
69 .S ^TMP($J,"RMPREO",LINE,0)=RRX
70 .S ^TMP($J,"RMPREOEE",LINE,0)=RMPRA
71 Q
72 ;
73 ;
74SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ;set array
75 I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80))
76 D SET^VALM10(LINE,$$SETSTR^VALM1(STRING,@VALMAR@(LINE,0),COLUMN,CLREND))
77 I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLUMN,$L(STRING),ON,OFF)
78 Q
79 ;
80 ;
81HELP ; -- help code
82 S X="?" D DISP^XQORM1 W !!
83 Q
84 ;
85EXIT ; -- exit code
86 ;NOT XUSCLEAN
87 ;added by patch #62
88 ;if transaction still exist for linking, print message and re-link
89 I $D(^TMP($J,"RMPRPCE")) D G:RMENTSUS="L" EN
90 .S RMQUIT=0
91 .W @IOF D SMESS0^RMPRPCEL,CDIR^RMPRPCEL
92 K ^TMP($J,"RMPREO"),^TMP($J,"RMPREOEE")
93 Q
94 ;
95EXPND ; -- expand code
96 Q
Note: See TracBrowser for help on using the repository browser.