RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10 Apr 2019 3:05 PM
;;5.0;Radiology/Nuclear Medicine;**55,80,84,144,157**;Mar 16, 1998;Build 2
;
;Integration Agreements
;----------------------
;$$FIND1^DIC(2051); UPDATE^DIE(2053); $$DT^XLFDT(10103); $$UP^XLFSTR(10104)
;
ADENDUM ; This functions store new lines of text at the end of the existing
;impression and report text. If this report is being amended through the
;teleradiology service, add the addendum text to the IMPRESSION TEXT (#300)
;field only. Note: Only ADENDUM was edited for RA*5.0*84 gjc/09.18.07
N A,COUNTER,I,J,NODE,ROOT,SUB,X,Y
;NODE = ^RARPT(RARPT,"I" -or- "R" -> where the data is to be stored...
;ROOT = ^TMP("RARPT-REC",$J,RASUB -> where the addendum data resides...
F A="I","R" D K I,J
.S SUB=$S(A="I":"RAIMP",1:"RATXT"),ROOT=$NA(^TMP("RARPT-REC",$J,RASUB,SUB)) Q:'$O(@ROOT@(0))
.S NODE=$NA(^RARPT(RARPT,A))
.S COUNTER=+$O(@NODE@($C(32)),-1) ;last record #
.;
.;if there is existing text, add a null line for space.
.I '($D(I)#2),(COUNTER>0) S COUNTER=COUNTER+1,@NODE@(COUNTER,0)=$C(32),I=""
.;
.S Y=0 F S Y=$O(@ROOT@(Y)) Q:'Y D
..S X=@ROOT@(Y)
..;if addendum text is to be the original text no spacer is needed ('Addendum:' tag applied)
..;if prior report or impression text exist, insert a blank as a spacer
..;^RARPT(RARPT,"I",1,0)="original impression"
..;^RARPT(RARPT,"I",2,0)="" <- insert a null line as a spacer
..;^RARPT(RARPT,"I",3,0)="Addendum: first line of addendum" ** NOTE 'Addendum:' tag **
..;^RARPT(RARPT,"I",4,0)="second line of addendum"
..;...
..;^RARPT(RARPT,"I",N,0)="Nth and last line of addendum"
..S COUNTER=COUNTER+1
..;set the first line of the addendum w/header: 'Addendum: '
..I '($D(J)#2) S X="Addendum: "_X,J=""
..S @NODE@(COUNTER,0)=X
..Q
.S @NODE@(0)="^^"_COUNTER_"^"_COUNTER_"^"_$$DT^XLFDT()
.Q
Q
;
ERR(A) ; Invalid impression/report text message.
; Input: 'A' - either "I" for impression, or "R" for report
; Output: the appropriate error message
Q "Invalid "_$S(A="I":"Impression",1:"Report")_" Text"
;
DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal
; to primary Dx code pntr value. Set RASECDX(x) to the secondary
; Dx code(s) if any.
N RAXFIRST
S I=0,RAXFIRST=1
K RASECDX
; KLM/p157 Check for primary designation and save position.
I $D(^TMP("RARPT-REC",$J,RASUB,"RADX","PDX")) S RAPRIM=$O(^TMP("RARPT-REC",$J,RASUB,"RADX","PDX",0))
I $G(RAPRIM)>0 S RAXFIRST=0 ;if primary designation, don't need RAXFIRST
F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RADX",I)) Q:I'>0 D Q:$D(RAERR)
. S RADIAG=$G(^TMP("RARPT-REC",$J,RASUB,"RADX",I))
. ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR)
. Q:RADIAG']"" ;Missing Diagnostic Code Patch 80
. ; If RADXIEN is a number, set RADXIEN to what is assumed to be a
. ; valid pointer (ien) for file 78.3
. I +RADIAG=RADIAG S RADXIEN=RADIAG
. ; If RADIAG is in a free text format, convert the external value
. ; into the ien for file 78.3
. I +RADIAG'=RADIAG S RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG)
. I '$D(^RA(78.3,RADXIEN,0)) S RAERR="Invalid Diagnostic Code" Q
. ;KLM/p144 Reject inactive DX codes
. I $P(^RA(78.3,RADXIEN,0),U,5)="Y" S RAERR="Inactive Diagnostic Code: "_RADXIEN Q
. ;p157 Primary may not be the first entry.. check if RAPRIM is the same as count.
. I RAXFIRST!($G(RAPRIM)=I) S RADX=RADXIEN,RAXFIRST=0 Q ; RADX=pri. Dx Code
. ; are any of the sec. Dx codes equal to our pri. Dx code?
. ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR)
. Q:RADXIEN=$G(RADX) ;Secondary Dx codes must differ from the primary Dx code Patch 80
. ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR)
. Q:$D(RASECDX(RADXIEN))#2 ;Duplicate secondary Dx codes. Patch 80
. S RASECDX(RADXIEN)="" ; set the sec. Dx array
. Q
K I,RADIAG,RADXIEN
Q
SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple
; called from RAHLO. Needs RADFN,RADTI & RACNI to function.
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D KILSECDG^RAHLO4
;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN
;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI)
;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^")
;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX
;. Q
;D UPDATE^DIE("","RAFDA",,"RAERR")
;I $D(RAERR) M ^TMP("ERR")=RAERR
;
N RAX S RAX=0
N RAFDA,RA2
K RAFDA
; K ^TMP("RAERR",$J)
S RA2=RACNI_","_RADTI_","_RADFN
F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
. S RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX
D UPDATE^DIE("","RAFDA",,"RAERR")
; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR
;
Q
IMPTXT ; Check if the impression text consists only of the string
; 'impression:". If 'impression:' is the only set of characters,
; (spaces are excluded) then delete the "RAIMP" node.
N RA1 S RA1=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))
Q:'RA1 N RAIMP S RAIMP=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))
I $$UP^XLFSTR($E(RAIMP,1,11))="IMPRESSION:" D
. S $E(RAIMP,1,11)="" ; strip out 'impression:' if it is the first
. ; eleven chars of the impression text
. ; now strip off leading spaces from the remaining
. ; text that led with 'impression:' if present
. F I1=1:1 S:$E(RAIMP,I1)'=" " RAIMP=$E(RAIMP,I1,99999) Q:$E(RAIMP)'=" "
. S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)=RAIMP
. Q
Q:$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1)) ; more imp. text follows
K:$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1))="" ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RA1) ; if only "RAIMP" node null, delete "RAIMP" node
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLO2 5781 printed Dec 13, 2024@02:35:22 Page 2
RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10 Apr 2019 3:05 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**55,80,84,144,157**;Mar 16, 1998;Build 2
+2 ;
+3 ;Integration Agreements
+4 ;----------------------
+5 ;$$FIND1^DIC(2051); UPDATE^DIE(2053); $$DT^XLFDT(10103); $$UP^XLFSTR(10104)
+6 ;
ADENDUM ; This functions store new lines of text at the end of the existing
+1 ;impression and report text. If this report is being amended through the
+2 ;teleradiology service, add the addendum text to the IMPRESSION TEXT (#300)
+3 ;field only. Note: Only ADENDUM was edited for RA*5.0*84 gjc/09.18.07
+4 NEW A,COUNTER,I,J,NODE,ROOT,SUB,X,Y
+5 ;NODE = ^RARPT(RARPT,"I" -or- "R" -> where the data is to be stored...
+6 ;ROOT = ^TMP("RARPT-REC",$J,RASUB -> where the addendum data resides...
+7 FOR A="I","R"
Begin DoDot:1
+8 SET SUB=$SELECT(A="I":"RAIMP",1:"RATXT")
SET ROOT=$NAME(^TMP("RARPT-REC",$JOB,RASUB,SUB))
if '$ORDER(@ROOT@(0))
QUIT
+9 SET NODE=$NAME(^RARPT(RARPT,A))
+10 ;last record #
SET COUNTER=+$ORDER(@NODE@($CHAR(32)),-1)
+11 ;
+12 ;if there is existing text, add a null line for space.
+13 IF '($DATA(I)#2)
IF (COUNTER>0)
SET COUNTER=COUNTER+1
SET @NODE@(COUNTER,0)=$CHAR(32)
SET I=""
+14 ;
+15 SET Y=0
FOR
SET Y=$ORDER(@ROOT@(Y))
if 'Y
QUIT
Begin DoDot:2
+16 SET X=@ROOT@(Y)
+17 ;if addendum text is to be the original text no spacer is needed ('Addendum:' tag applied)
+18 ;if prior report or impression text exist, insert a blank as a spacer
+19 ;^RARPT(RARPT,"I",1,0)="original impression"
+20 ;^RARPT(RARPT,"I",2,0)="" <- insert a null line as a spacer
+21 ;^RARPT(RARPT,"I",3,0)="Addendum: first line of addendum" ** NOTE 'Addendum:' tag **
+22 ;^RARPT(RARPT,"I",4,0)="second line of addendum"
+23 ;...
+24 ;^RARPT(RARPT,"I",N,0)="Nth and last line of addendum"
+25 SET COUNTER=COUNTER+1
+26 ;set the first line of the addendum w/header: 'Addendum: '
+27 IF '($DATA(J)#2)
SET X="Addendum: "_X
SET J=""
+28 SET @NODE@(COUNTER,0)=X
+29 QUIT
End DoDot:2
+30 SET @NODE@(0)="^^"_COUNTER_"^"_COUNTER_"^"_$$DT^XLFDT()
+31 QUIT
End DoDot:1
KILL I,J
+32 QUIT
+33 ;
ERR(A) ; Invalid impression/report text message.
+1 ; Input: 'A' - either "I" for impression, or "R" for report
+2 ; Output: the appropriate error message
+3 QUIT "Invalid "_$SELECT(A="I":"Impression",1:"Report")_" Text"
+4 ;
DIAG ; Check if the Diagnostic Codes passed are valid. Set RADX equal
+1 ; to primary Dx code pntr value. Set RASECDX(x) to the secondary
+2 ; Dx code(s) if any.
+3 NEW RAXFIRST
+4 SET I=0
SET RAXFIRST=1
+5 KILL RASECDX
+6 ; KLM/p157 Check for primary designation and save position.
+7 IF $DATA(^TMP("RARPT-REC",$JOB,RASUB,"RADX","PDX"))
SET RAPRIM=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RADX","PDX",0))
+8 ;if primary designation, don't need RAXFIRST
IF $GET(RAPRIM)>0
SET RAXFIRST=0
+9 FOR
SET I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RADX",I))
if I'>0
QUIT
Begin DoDot:1
+10 SET RADIAG=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RADX",I))
+11 ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR)
+12 ;Missing Diagnostic Code Patch 80
if RADIAG']""
QUIT
+13 ; If RADXIEN is a number, set RADXIEN to what is assumed to be a
+14 ; valid pointer (ien) for file 78.3
+15 IF +RADIAG=RADIAG
SET RADXIEN=RADIAG
+16 ; If RADIAG is in a free text format, convert the external value
+17 ; into the ien for file 78.3
+18 IF +RADIAG'=RADIAG
SET RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG)
+19 IF '$DATA(^RA(78.3,RADXIEN,0))
SET RAERR="Invalid Diagnostic Code"
QUIT
+20 ;KLM/p144 Reject inactive DX codes
+21 IF $PIECE(^RA(78.3,RADXIEN,0),U,5)="Y"
SET RAERR="Inactive Diagnostic Code: "_RADXIEN
QUIT
+22 ;p157 Primary may not be the first entry.. check if RAPRIM is the same as count.
+23 ; RADX=pri. Dx Code
IF RAXFIRST!($GET(RAPRIM)=I)
SET RADX=RADXIEN
SET RAXFIRST=0
QUIT
+24 ; are any of the sec. Dx codes equal to our pri. Dx code?
+25 ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR)
+26 ;Secondary Dx codes must differ from the primary Dx code Patch 80
if RADXIEN=$GET(RADX)
QUIT
+27 ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR)
+28 ;Duplicate secondary Dx codes. Patch 80
if $DATA(RASECDX(RADXIEN))#2
QUIT
+29 ; set the sec. Dx array
SET RASECDX(RADXIEN)=""
+30 QUIT
End DoDot:1
if $DATA(RAERR)
QUIT
+31 KILL I,RADIAG,RADXIEN
+32 QUIT
SECDX ; Kill old sec. Dx nodes, and add the new ones into the 70.14 multiple
+1 ; called from RAHLO. Needs RADFN,RADTI & RACNI to function.
+2 if '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+3 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
DO KILSECDG^RAHLO4
+4 ;K RAFDA N RAX S RAX=0,RAFDA(70,"?1,",.01)=RADFN
+5 ;S RAFDA(70.02,"?2,?1,",.01)=(9999999.9999-RADTI)
+6 ;S RAFDA(70.03,"?3,?2,?1,",.01)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^")
+7 ;F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
+8 ;. S RAFDA(70.14,"?"_RAX_"9,?3,?2,?1,",.01)=RAX
+9 ;. Q
+10 ;D UPDATE^DIE("","RAFDA",,"RAERR")
+11 ;I $D(RAERR) M ^TMP("ERR")=RAERR
+12 ;
+13 NEW RAX
SET RAX=0
+14 NEW RAFDA,RA2
+15 KILL RAFDA
+16 ; K ^TMP("RAERR",$J)
+17 SET RA2=RACNI_","_RADTI_","_RADFN
+18 FOR
SET RAX=$ORDER(RASECDX(RAX))
if RAX'>0
QUIT
Begin DoDot:1
+19 SET RAFDA(70.14,"?+"_RAX_"9,"_RA2_",",.01)=RAX
End DoDot:1
+20 DO UPDATE^DIE("","RAFDA",,"RAERR")
+21 ; I $D(RAERR) M ^TMP("RAERR",$J)=RAERR
+22 ;
+23 QUIT
IMPTXT ; Check if the impression text consists only of the string
+1 ; 'impression:". If 'impression:' is the only set of characters,
+2 ; (spaces are excluded) then delete the "RAIMP" node.
+3 NEW RA1
SET RA1=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",0))
+4 if 'RA1
QUIT
NEW RAIMP
SET RAIMP=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",RA1))
+5 IF $$UP^XLFSTR($EXTRACT(RAIMP,1,11))="IMPRESSION:"
Begin DoDot:1
+6 ; strip out 'impression:' if it is the first
SET $EXTRACT(RAIMP,1,11)=""
+7 ; eleven chars of the impression text
+8 ; now strip off leading spaces from the remaining
+9 ; text that led with 'impression:' if present
+10 FOR I1=1:1
if $EXTRACT(RAIMP,I1)'=" "
SET RAIMP=$EXTRACT(RAIMP,I1,99999)
if $EXTRACT(RAIMP)'=" "
QUIT
+11 SET ^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",RA1)=RAIMP
+12 QUIT
End DoDot:1
+13 ; more imp. text follows
if $ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",RA1))
QUIT
+14 ; if only "RAIMP" node null, delete "RAIMP" node
if $GET(^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",RA1))=""
KILL ^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",RA1)
+15 QUIT
