source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL5.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 7.4 KB
Line 
1RAUTL5 ;HISC/CAH,FPT,GJC-Utility Routine ;3/12/98 13:27
2 ;;5.0;Radiology/Nuclear Medicine;**8,26,75**;Mar 16, 1998;Build 4
3CH ; Populate the 'CLINICAL HISTORY' field (#400); file 75.1 (^RAO(75.1))
4 ; Called from 'CREATE1^RAORD1'.
5 ;
6 ;Ask for 'Reason for Study' (required)
7 ;Note: RAOUT & RAREAST will be needed later in the ordering process
8 D STYREA(.RAOUT,.RAREAST) I $D(RAOUT) D XIT QUIT
9 K ^TMP($J,"RAWP") ;must always start with a clean slate...
10 ;
11CH1 ;ask/re-ask 'CLINICAL HISTORY'
12 I $D(RAVSTFLG),$D(RAVLEDTI),$D(RAVLECNI),$D(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,"H")) S:$D(^("H",0)) ^TMP($J,"RAWP",0)=^(0) F RAI=1:1 Q:'$D(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,"H",RAI,0)) S ^TMP($J,"RAWP",RAI,0)=^(0)
13 ;Display the Rad/Nuc Med division specific clin. history message (in any)
14 I $L($G(^RA(79,+RADIV,"HIS"))) W !!?3,$C(7),^("HIS"),! K DIR S DIR(0)="E" D ^DIR
15 I $D(DIRUT) D XIT Q
16 N RAYN S DIC="^TMP("_$J_",""RAWP"",",DWPK=1,DIWESUB="Clinical History"
17 W !,"CLINICAL HISTORY FOR EXAM" D EN^DIWE K DIC,DIWESUB,DWPK
18 I '$O(^TMP($J,"RAWP",0)) D XIT QUIT
19 K DIC S DIC="^TMP("_$J_",""RAWP"",",DWPK=1
20 S RAWPFLG=$$VALWP("^TMP("_$J_",""RAWP"","),RAYN=0
21 I 'RAWPFLG D D:RAYN'=1 PURGECH Q:RAYN'=1 G CH1
22 .W !!,$C(7),"Text must be at least two (2) alphanumeric characters in length.",!
23 .N X,Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="Yes"
24 .S DIR("A")="Do you want to enter a proper clinical history for this request"
25 .S DIR("?",1)="The clinical history must at a minimum consist of two alphanumeric characters."
26 .S DIR("?",2)="Enter 'Y' to enter a proper clinical history, or 'N' to bypass entering"
27 .S DIR("?")="the clinical history for this request." D ^DIR
28 .S:+Y RAYN=1 ;the user will to try to enter a CH
29 .S:$D(DIRUT)#2 RAYN=-1 ;timeout or caret entered, exit w/o a CH
30 .;else the user enters 'No' and does not want to enter a CH
31 .K DIR,DIROUT,DIRUT,DTOUT,DUOUT
32 .Q
33 I RAYN<1 D XIT Q
34WPLEN ;Is clin hist too long to go into a local array for OE/RR HL7 msg?
35 N RACNT,RAX S (RACNT,RAX)=0
36 F S RAX=$O(^TMP($J,"RAWP",RAX)) S RACNT=RACNT+1 Q:RAX'>0
37 I RACNT>350 S RAYN=0 D D:RAYN'=1 PURGECH Q:RAYN'=1 G CH1
38 .W !!,$C(7),"The clinical history cannot exceed 350 lines in length."
39 .N X,Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT
40 .S DIR(0)="Y",DIR("B")="Yes"
41 .S DIR("A")="Do you want to enter a proper clinical history for this request"
42 .S DIR("?",1)="The clinical history cannot exceed 350 lines in length and must"
43 .S DIR("?",2)=" at a minimum consist of two alphanumeric characters."
44 .S DIR("?",3)="Enter 'Y' to enter a proper clinical history, or 'N' to bypass"
45 .S DIR("?")="entering the clinical history for this request." D ^DIR
46 .S:+Y RAYN=1 ;the user will to try to enter a CH
47 .S:$D(DIRUT)#2 RAYN=-1 ;timeout or caret entered, exit w/o a CH
48 .;else the user enters 'No' and does not want to enter a CH
49 .K DIR,DIROUT,DIRUT,DTOUT,DUOUT
50 .Q
51XIT ;kill variable(s), exit CH subroutine
52 K RAWPFLG
53 Q
54 ;
55VALWP(RAROOT) ; Validate word processing field.
56 ; Pass back '1' if data is valid, '0' if not valid.
57 ; at least 2 alphanumeric char's required
58 Q:'$O(@(RAROOT_"0)")) 0
59 N CHAR,CNT,WL,WPFLG,X,Y,Z
60 S (WPFLG,X)=0
61 F S X=$O(@(RAROOT_X_")")) Q:X'>0 D Q:WPFLG
62 . S (CNT,WL)=0
63 . S Y=$G(@(RAROOT_X_",0)")) Q:Y']""
64 . S WL=$L(Y)
65 . F Z=1:1:WL D Q:WPFLG
66 .. S CHAR=$E(Y,Z) S:CHAR?1AN CNT=CNT+1
67 .. S:CHAR'?1AN&(CNT>0) CNT=0 S:CNT=2 WPFLG=1
68 .. Q
69 . Q
70 Q WPFLG
71RDQ(D0) ; Used by input transform on ^DD(74.31,2
72 ; Checks for unprinted reports associated with REPORT
73 ; DISTRIBUTION QUEUE of internal entry number of D0.
74 N %,%Y,FOUND,RA744
75 S (FOUND,RA744)=0
76 F S RA744=$O(^RABTCH(74.4,"C",D0,RA744)) Q:RA744'>0!FOUND D
77 . S FOUND=($P($G(^RABTCH(74.4,RA744,0)),"^",4)'>0)
78 . Q
79 Q:'FOUND
80 W !!,"*** UNPRINTED REPORTS IN THE QUEUE ! ***"
81 W !,"If this queue is inactivated before printing, these reports will be",!,"removed from the queue."
82 F D Q:%
83 . W !!,"Are you sure you want to remove these reports"
84 . S %=2 D YN^DICN
85 . I '% W !!?5,"Please answer Y(es) or N(o)."
86 . Q
87 I %'=1 W !,"Inactivation date deleted" K X
88 Q
89ATND(RADFN,DATE) ;Returns the external form of the ATTENDING PHYSICIAN
90 ;for patient RADFN (IEN file #2) on date DATE (FM format)
91 N DPT,VA200,VAIP,X
92 S DFN=RADFN,VAIP("D")=DATE,VA200=1
93 I DATE D IN5^VADPT
94 S X=$P($G(VAIP(18)),"^",2),X=$S(X]"":X,1:"UNKNOWN")
95 Q X
96PRIM(RADFN,DATE) ;Returns the external form of the PRIMARY PHYSICIAN
97 ;for patient RADFN (IEN file #2) on date DATE (FM format)
98 N DPT,VA200,VAIP,X
99 S DFN=RADFN,VAIP("D")=DATE,VA200=1
100 I DATE D IN5^VADPT
101 I '+$G(VAIP(7)) D
102 . ; If the Primary Physician is not found (based on inpatient episode)
103 . ; find the current PC Practitioner (See patch SD*5.3*30)
104 . ; VAIP(7) is null at this point. VAIP(7) will exit this DO block
105 . ; set to the Primary Care Practitioner or null.
106 . N X S X="SDUTL3" X ^%ZOSF("TEST")
107 . S:$T VAIP(7)=$$OUTPTPR^SDUTL3(RADFN)
108 . Q
109 S X=$P($G(VAIP(7)),"^",2),X=$S(X]"":X,1:"UNKNOWN")
110 Q X
111EOS() ; 'End Of Screen' prompt for terminals only, check user response.
112 Q:$E(IOST,1,2)'="C-" 0
113 N RAY,X,X1,X2,X3,Y,Y0,Y1,Y2,Y3,Y4,Y5
114 ;Returns 1 if user enters anything other than a carriage return
115 K DIR S DIR(0)="E" D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT
116 S RAY='+Y
117 Q RAY
118XTERNAL(Y,C) ; Change internal format to external format
119 ; 'Y' is the internal form of the data
120 ; 'C' defines the data type of the variable 'Y'
121 D:Y]"" Y^DIQ
122 Q Y
123PROCMSG(RAPRI) ; Print the appropriate procedure messages. Called from
124 ; DESDT^RAUTL12. This code works under the assumption that the
125 ; user has entered through OE/RR.
126 ;ATTENTION: this code must be parallet to code in EN2^RAPRI
127 Q:+$G(RASTOP) ; Do not display if displayed in the past.
128 I $O(^RAMIS(71,RAPRI,3,0)) D S RASTOP=1
129 . N I,RAX,X S I=0
130 . W !!?5,"NOTE: The following special requirements apply to this "
131 . W "procedure:",$C(7),!
132 . F S I=+$O(^RAMIS(71,RAPRI,3,I)) Q:'I D
133 .. S RAX=+$G(^RAMIS(71,RAPRI,3,I,0))
134 .. I $D(^RAMIS(71.4,+RAX,0)) D
135 ... I $Y>(IOSL-6) D READ^ORUTL W @IOF
136 ... S X=$G(^RAMIS(71.4,+RAX,0)) W !?3,X
137 ... Q
138 .. Q
139 . Q
140 I $O(^RAMIS(71,RAPRI,"EDU",0)),($$UP^XLFSTR($P($G(^RAMIS(71,RAPRI,0)),"^",17))="Y") D
141 . W:+$O(^RAMIS(71,+RAPRI,3,0))>0 !!
142 . N DIW,DIWF,DIWL,DIWR,RAX,X
143 . K ^UTILITY($J,"W") S DIWF="W",DIWL=1,DIWR=75,RAX=0
144 . F S RAX=$O(^RAMIS(71,RAPRI,"EDU",RAX)) Q:RAX'>0 D
145 .. I $Y>(IOSL-4) D READ^ORUTL W @IOF
146 .. S X=$G(^RAMIS(71,RAPRI,"EDU",RAX,0)) D ^DIWP
147 .. Q
148 . I $Y>(IOSL-4) D READ^ORUTL W @IOF
149 . D ^DIWW
150 . W !
151 . Q
152 Q
153MIDNGHT(X) ; Check if the date passed in is midnight. If it is, add one
154 ; minute to the date/time. Fixes infinite loop problem in FM when
155 ; midnight.
156 ; Input: X-Current system date/time (derived from $$NOW^XLFDT)
157 S:X["." X=$E(X,1,($F(X,".")+3)) ; chop off seconds IF there's decimal
158 S:+$P(X,".",2)=24!(+$P(X,".",2)=0) X=$$FMADD^XLFDT(X,0,0,1,0) ; add a minute to midnight
159 Q X
160 ;
161STYREA(RAOUT,RAREAST) ;ask for the 'Reason for Study' P75 (required)
162 ;return: RAOUT-set if the user enters '^' or times out
163 ; RAREAST-the reason entered by the user
164 N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="75.1,1.1" D ^DIR
165 S:$D(DIRUT)#2 RAOUT="" Q:$D(RAOUT)#2 S RAREAST=Y
166 Q
167 ;
168DIWP(DIWL,DIWR,X) ; work ^DIWP & ^DIWW FM call "WRITE" mode P75
169 ;input: DIWL=left margin
170 ; DIWR=right margin
171 ; X=text to be formatted
172 N %,DIW,DIWF,DIWT,DN,I,Z
173 K ^UTILITY($J,"W") S DIWF="W" D ^DIWP,^DIWW
174 K ^UTILITY($J,"W")
175 Q
176 ;
177PURGECH ;Delete the invalid 'CLINICAL HISTORY'; inform the user
178 ;of the deletion (user interactive roll & scroll interface).
179 W !,"Invalid CLINICAL HISTORY deleted..." K ^TMP($J,"RAWP")
180 Q
181 ;
Note: See TracBrowser for help on using the repository browser.