- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m
r613 r623 1 RAHLO2 ;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 ; 8 ADENDUM ; 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 ; 42 ERR(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 ; 47 DIAG ; 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 74 SECDX ; 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 98 IMPTXT ; 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 1 RAHLO2 ;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 3 ADENDUM ; 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 25 ERR(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 ; 30 DIAG ; 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 57 SECDX ; 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 81 IMPTXT ; 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 TracChangeset
for help on using the changeset viewer.
