source: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 4.5 KB
Line 
1RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02
2 ;;5.0;Radiology/Nuclear Medicine;**55,80**;Mar 16, 1998;Build 19
3ADENDUM ; store new lines at the end of existing text
4 F A="I","R" D
5 . I $O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) D
6 .. S RACNT=+$O(^RARPT(RARPT,A,9999999),-1),RASTRNDE=RACNT+1
7 .. ; Check if the impression an/or report text sent with the addendum
8 .. ; is to be the initial text added to the word processing multiples.
9 .. ; RASTRNDE=the first subscript where impression/report data is to
10 .. ; be stored. If no existing impression/report text data, RASTRNDE
11 .. ; equals one. If one & RACNT equals one, don't add a blank line
12 .. ; before adding addendum text. If RASTRNDE & RACNT both >1, add
13 .. ; the blank line.
14 .. S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I)) Q:I'>0 D
15 ... S RACNT=RACNT+1,L=$G(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I))
16 ... S:I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) L="Addendum: "_L ; if the first line, append 'addendum:'
17 ... I (RASTRNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,A,RACNT,0)=" ",RACNT=RACNT+1
18 ... S ^RARPT(RARPT,A,RACNT,0)=L
19 ... Q
20 .. S ^RARPT(RARPT,A,0)="^^"_RACNT_"^"_RACNT_"^"_RADATE
21 .. Q
22 . Q
23 K A,I,L,RACNT,RASTRNDE
24 Q
25ERR(A) ; Invalid impression/report text message.
26 ; Input: 'A' - either "I" for impression, or "R" for report
27 ; Output: the appropriate error message
28 Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text"
29 ;
30DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal
31 ; to primary Dx code pntr value. Set RASECDX(x) to the secondary
32 ; Dx code(s) if any.
33 N RAXFIRST
34 S I=0,RAXFIRST=1
35 K RASECDX
36 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR)
37 . S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I))
38 . ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR)
39 . Q:RADIAG']"" ;Missing Diagnostic Code Patch 80
40 . ; If RADXIEN is a number, set RADXIEN to what is assumed to be a
41 . ; valid pointer (ien) for file 78.3
42 . I +RADIAG=RADIAG S RADXIEN=RADIAG
43 . ; If RADIAG is in a free text format, convert the external value
44 . ; into the ien for file 78.3
45 . I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG)
46 . I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q
47 . IF RAXFIRST S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code
48 . ; are any of the sec. Dx codes equal to our pri. Dx code?
49 . ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR)
50 . Q:RADXIEN=RADX ;Secondary Dx codes must differ from the primary Dx code Patch 80
51 . ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR)
52 . Q:$D(RASECDX(RADXIEN))#2 ;Duplicate secondary Dx codes. Patch 80
53 . S RASECDX(RADXIEN)="" ; set the sec. Dx array
54 . Q
55 K I,RADIAG,RADXIEN
56 Q
57SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple
58 ; called from RAHLO. Needs RADFN,RADTI & RACNI to function.
59 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
60 I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4
61 ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN
62 ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI)
63 ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^")
64 ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
65 ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX
66 ;. Q
67 ;D UPDATE^DIE("","RAFDA",,"RAERR")
68 ;I $D(RAERR) M ^TMP("ERR")=RAERR
69 ;
70 N RAX S RAX=0
71 N RAFDA,RA2
72 K RAFDA
73 ; K ^TMP("RAERR",$J)
74 S RA2=RACNI_","_RADTI_","_RADFN
75 F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
76 . S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX
77 D UPDATE^DIE("","RAFDA",,"RAERR")
78 ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR
79 ;
80 Q
81IMPTXT ; Check if the impression text consists only of the string
82 ; 'impression:". If 'impression:' is the only set of characters,
83 ; (spaces are excluded) then delete the "RAIMP" node.
84 N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))
85 Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))
86 I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D
87 . S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first
88 . ; eleven chars of the impression text
89 . ; now strip off leading spaces from the remaining
90 . ; text that led with 'impression:' if present
91 . F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" "
92 . S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP
93 . Q
94 Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows
95 K:$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))="" ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1) ; if only "RAIMP" node null, delete "RAIMP" node
96 Q
Note: See TracBrowser for help on using the repository browser.