- RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02
- ;;5.0;Radiology/Nuclear Medicine;**55,80,84**;Mar 16, 1998;Build 13
- ;
- ;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
- 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
- . IF RAXFIRST 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=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
- RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97 09:02
- +1 ;;5.0;Radiology/Nuclear Medicine;**55,80,84**;Mar 16, 1998;Build 13
- +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 FOR
- SET I=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,"RADX",I))
- IF I'>0
- QUIT
- Begin DoDot:1
- +7 SET RADIAG=$GET(^TMP("RARPT-REC",$JOB,RASUB,"RADX",I))
- +8 ;S:RADIAG']"" RAERR="Missing Diagnostic Code" Q:$D(RAERR)
- +9 ;Missing Diagnostic Code Patch 80
- IF RADIAG']""
- QUIT
- +10 ; If RADXIEN is a number, set RADXIEN to what is assumed to be a
- +11 ; valid pointer (ien) for file 78.3
- +12 IF +RADIAG=RADIAG
- SET RADXIEN=RADIAG
- +13 ; If RADIAG is in a free text format, convert the external value
- +14 ; into the ien for file 78.3
- +15 IF +RADIAG'=RADIAG
- SET RADXIEN=$$FIND1^DIC(78.3,"","X",RADIAG)
- +16 IF '$DATA(^RA(78.3,RADXIEN,0))
- SET RAERR="Invalid Diagnostic Code"
- QUIT
- +17 ; RADX=pri. Dx Code
- IF RAXFIRST
- SET RADX=RADXIEN
- SET RAXFIRST=0
- QUIT
- +18 ; are any of the sec. Dx codes equal to our pri. Dx code?
- +19 ;S:RADXIEN=RADX RAERR="Secondary Dx codes must differ from the primary Dx code." Q:$D(RAERR)
- +20 ;Secondary Dx codes must differ from the primary Dx code Patch 80
- IF RADXIEN=RADX
- QUIT
- +21 ;S:$D(RASECDX(RADXIEN))#2 RAERR="Duplicate secondary Dx codes." Q:$D(RAERR)
- +22 ;Duplicate secondary Dx codes. Patch 80
- IF $DATA(RASECDX(RADXIEN))#2
- QUIT
- +23 ; set the sec. Dx array
- SET RASECDX(RADXIEN)=""
- +24 QUIT
- End DoDot:1
- IF $DATA(RAERR)
- QUIT
- +25 KILL I,RADIAG,RADXIEN
- +26 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