source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRESN.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PXRMRESN ; SLC/PJH - Edit/Inquire resolution statuses ;03/17/2000
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4START N DIC,PXRMGTYP,PXRMHD,PXRMRESN,Y
5 ;Select reminder category for display
6SELECT ;General selection
7 S PXRMHD="Reminder Resolution Status",PXRMGTYP="RESN",PXRMRESN=""
8 D START^PXRMSEL(PXRMHD,PXRMGTYP,"PXRMRESN")
9 ;Should return a value
10 I PXRMRESN D G SELECT
11 .S PXRMHD="REMINDER RESOLUTION STATUS NAME:"
12 .;Listman option
13 .D START^PXRMGEN(PXRMHD,PXRMGTYP,PXRMRESN)
14 ;
15END Q
16 ;
17 ;REMINDER RESOLUTION STATUSES #801.9
18 ;-----------------------------------
19 ;Temporary list of STATUSES
20DISP N CNT,CODE,DES,SUB,TXT
21 W #,"REMINDER RESOLUTION STATUS SELECTION",!
22 S CODE="",CNT=0
23 F S CODE=$O(^PXRMD(801.9,"B",CODE)) Q:CODE="" D
24 .S CNT=CNT+1
25 .W !,CODE
26 W !
27 Q
28 ;
29 ;Build display for selected status - Called from PXRMGEN
30 ;---------------------------------------------------------
31RESN(PXRMRESN) ;
32 N DATA,DARRAY,SUB
33 S VALMCNT=0 K ^TMP("PXRMGENS",$J),^TMP("PXRMGEN",$J)
34 ;
35 ;Format headings to include resolution name
36 S HEADER=PXRMHD_" "_$P(^PXRMD(801.9,PXRMRESN,0),U)
37 ;
38 ;Build Reminder Resolution Status Display
39 D BUILD(.DARRAY,PXRMRESN) M ^TMP("PXRMGENS",$J)=DARRAY
40 ;
41 ;Put the list into the array List Manager is using.
42 S SUB=""
43 S VALMCNT=0
44 F S SUB=$O(^TMP("PXRMGENS",$J,SUB)) Q:SUB="" D
45 .S DATA=$G(^TMP("PXRMGENS",$J,SUB))
46 .S VALMCNT=VALMCNT+1
47 .S ^TMP("PXRMGEN",$J,VALMCNT,0)=DATA
48 S ^TMP("PXRMGEN",$J,"VALMCNT")=VALMCNT
49 K ^TMP("PXRMGENS",$J)
50 ;Create headings
51 D CHGCAP^VALM("HEADER1","")
52 D CHGCAP^VALM("HEADER2","")
53 D CHGCAP^VALM("HEADER3","")
54 Q
55 ;
56 ;Build Resolution Status Inquiry array
57 ;-------------------------------------
58BUILD(ARRAY,D0) ;
59 N DIWF,DIWL,DIWR,IC,SUB,TAB,TXT,X
60 N ABBR,COL,CREA,DATA,DESC,FOUND,INACT,REST
61 S DIWF="C70",DIWL=0,DIWR=70,IC=0
62 K ^UTILITY($J,"W")
63 ;Get Resolution status details
64 S DATA=$G(^PXRMD(801.9,D0,0))
65 S DESC=$P(DATA,U),ABBR=$P(DATA,U,2),COL=$P(DATA,U,3),INACT=$P(DATA,U,4)
66 S CREA=$P(DATA,U,5),REST=$P(DATA,U,6)
67 ;
68 ;Resolution Status
69 S TXT="Resolution Status: "_DESC
70 ;Restricted edit is same as National
71 S:REST TXT="National "_TXT D SET(0,TXT,1)
72 ;
73 S TXT="Resolution Status Description" D SET(0,TXT,0)
74 ;Get Resolution Status description
75 S SUB=0,TAB=0,FOUND=0
76 F S SUB=$O(^PXRMD(801.9,D0,1,SUB)) Q:SUB="" D
77 .S X=$G(^PXRMD(801.9,D0,1,SUB,0))
78 .D ^DIWP
79 F S SUB=$O(^UTILITY($J,"W",0,SUB)) Q:SUB="" D
80 .D SET(5,^UTILITY($J,"W",0,SUB,0),0) S FOUND=1
81 K ^UTILITY($J,"W")
82 ;Display no description message
83 I 'FOUND S TXT="*NONE*" D SET(5,TXT,0)
84 D SET(0,"",1)
85 ;
86 ;Related National Status from cross reference
87 I 'REST D
88 .;Get national code from cross reference
89 .N IEN S IEN=$O(^PXRMD(801.9,"AC",D0,""))
90 .;If none allocated say so
91 .I 'IEN S TXT="***UNDEFINED***"
92 .;Get name of national status and display
93 .I IEN S TXT=$P($G(^PXRMD(801.9,IEN,0)),U)
94 .S TXT="Related National Status: "_TXT D SET(3,TXT,0)
95 ;
96 ;Abbreviated Name
97 S TXT="Abbreviated name: "_ABBR D SET(10,TXT,0)
98 ;Report Column Headings
99 S TXT="Report Column Headings: "_ABBR D SET(4,TXT,0)
100 ;Inactive flag
101 S TXT="Inactive Flag: "_$S(INACT:"INACTIVE",1:"") D SET(13,TXT,0)
102 ;Creator for local codes
103 I CREA,'REST D
104 .S TXT="Creator: "_$$GET1^DIQ(200,CREA,.01) D SET(19,TXT,0)
105 ;Local Resolution Statuses
106 I REST D
107 .N LARRAY,LIEN S SUB=0,FOUND=0
108 .F S SUB=$O(^PXRMD(801.9,D0,10,SUB)) Q:'SUB D
109 ..S LIEN=$P($G(^PXRMD(801.9,D0,10,SUB,0)),U)
110 ..I LIEN S LARRAY(LIEN)="",FOUND=1
111 .S TXT="Local Resolution Statuses:" D SET(0,"",1),SET(0,TXT,0)
112 .I 'FOUND S TXT="*NONE*" D SET(5,TXT,0) Q
113 .S LIEN="" F S LIEN=$O(LARRAY(LIEN)) Q:'LIEN D
114 ..S TXT=$P($G(^PXRMD(801.9,LIEN,0)),U) D SET(4,TXT,0)
115 Q
116 ;
117 ;Save local array
118 ;----------------
119SET(TAB,TXT,LF) ;
120 ;Save main line
121 S IC=IC+1,ARRAY(IC)=$J("",TAB)_TXT
122 ;Additional line feeds
123 I LF D
124 .N CNT F CNT=1:1:LF S IC=IC+1,ARRAY(IC)=$J("",79)
125 Q
Note: See TracBrowser for help on using the repository browser.