source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m@ 619

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

initial load of WorldVistAEHR
File size: 5.1 KB
RevLine 
[613]1RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02
2 ;;5.0;Radiology/Nuclear Medicine;**55,80,84**;Mar 16, 1998;Build 13
3 ;
4 ;Integration Agreements
5 ;----------------------
6 ;$$FIND1^DIC(2051); UPDATE^DIE(2053); $$DT^XLFDT(10103); $$UP^XLFSTR(10104)
7 ;
8ADENDUM ; This functions store new lines of text at the end of the existing
9 ;impression and report text. If this report is being amended through the
10 ;teleradiology service, add the addendum text to the IMPRESSION TEXT (#300)
11 ;field only. Note: Only ADENDUM was edited for RA*5.0*84 gjc/09.18.07
12 N A,COUNTER,I,J,NODE,ROOT,SUB,X,Y
13 ;NODE = ^RARPT(RARPT,"I" -or- "R" -> where the data is to be stored...
14 ;ROOT = ^TMP("RARPT-REC",$J,RASUB -> where the addendum data resides...
15 F A="I","R" D K I,J
16 .S SUB=$S(A="I":"RAIMP",1:"RATXT"),ROOT=$NA(^TMP("RARPT-REC",$J,RASUB,SUB)) Q:'$O(@ROOT@(0))
17 .S NODE=$NA(^RARPT(RARPT,A))
18 .S COUNTER=+$O(@NODE@($C(32)),-1) ;last record #
19 .;
20 .;if there is existing text, add a null line for space.
21 .I '($D(I)#2),(COUNTER>0) S COUNTER=COUNTER+1,@NODE@(COUNTER,0)=$C(32),I=""
22 .;
23 .S Y=0 F S Y=$O(@ROOT@(Y)) Q:'Y D
24 ..S X=@ROOT@(Y)
25 ..;if addendum text is to be the original text no spacer is needed ('Addendum:' tag applied)
26 ..;if prior report or impression text exist, insert a blank as a spacer
27 ..;^RARPT(RARPT,"I",1,0)="original impression"
28 ..;^RARPT(RARPT,"I",2,0)="" <- insert a null line as a spacer
29 ..;^RARPT(RARPT,"I",3,0)="Addendum: first line of addendum" ** NOTE 'Addendum:' tag **
30 ..;^RARPT(RARPT,"I",4,0)="second line of addendum"
31 ..;...
32 ..;^RARPT(RARPT,"I",N,0)="Nth and last line of addendum"
33 ..S COUNTER=COUNTER+1
34 ..;set the first line of the addendum w/header: 'Addendum: '
35 ..I '($D(J)#2) S X="Addendum: "_X,J=""
36 ..S @NODE@(COUNTER,0)=X
37 ..Q
38 .S @NODE@(0)="^^"_COUNTER_"^"_COUNTER_"^"_$$DT^XLFDT()
39 .Q
40 Q
41 ;
42ERR(A) ; Invalid impression/report text message.
43 ; Input: 'A' - either "I" for impression, or "R" for report
44 ; Output: the appropriate error message
45 Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text"
46 ;
47DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal
48 ; to primary Dx code pntr value. Set RASECDX(x) to the secondary
49 ; Dx code(s) if any.
50 N RAXFIRST
51 S I=0,RAXFIRST=1
52 K RASECDX
53 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR)
54 . S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I))
55 . ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR)
56 . Q:RADIAG']"" ;Missing Diagnostic Code Patch 80
57 . ; If RADXIEN is a number, set RADXIEN to what is assumed to be a
58 . ; valid pointer (ien) for file 78.3
59 . I +RADIAG=RADIAG S RADXIEN=RADIAG
60 . ; If RADIAG is in a free text format, convert the external value
61 . ; into the ien for file 78.3
62 . I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG)
63 . I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q
64 . IF RAXFIRST S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code
65 . ; are any of the sec. Dx codes equal to our pri. Dx code?
66 . ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR)
67 . Q:RADXIEN=RADX ;Secondary Dx codes must differ from the primary Dx code Patch 80
68 . ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR)
69 . Q:$D(RASECDX(RADXIEN))#2 ;Duplicate secondary Dx codes. Patch 80
70 . S RASECDX(RADXIEN)="" ; set the sec. Dx array
71 . Q
72 K I,RADIAG,RADXIEN
73 Q
74SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple
75 ; called from RAHLO. Needs RADFN,RADTI & RACNI to function.
76 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
77 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4
78 ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN
79 ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI)
80 ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^")
81 ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
82 ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX
83 ;. Q
84 ;D UPDATE^DIE("","RAFDA",,"RAERR")
85 ;I $D(RAERR) M ^TMP("ERR")=RAERR
86 ;
87 N RAX S RAX=0
88 N RAFDA,RA2
89 K RAFDA
90 ; K ^TMP("RAERR",$J)
91 S RA2=RACNI_","_RADTI_","_RADFN
92 F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
93 . S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX
94 D UPDATE^DIE("","RAFDA",,"RAERR")
95 ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR
96 ;
97 Q
98IMPTXT ; Check if the impression text consists only of the string
99 ; 'impression:". If 'impression:' is the only set of characters,
100 ; (spaces are excluded) then delete the "RAIMP" node.
101 N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))
102 Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))
103 I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D
104 . S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first
105 . ; eleven chars of the impression text
106 . ; now strip off leading spaces from the remaining
107 . ; text that led with 'impression:' if present
108 . F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" "
109 . S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP
110 . Q
111 Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows
112 K:$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))="" ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1) ; if only "RAIMP" node null, delete "RAIMP" node
113 Q
Note: See TracBrowser for help on using the repository browser.