RAIPS206 ;WOIFO/KLM - Post-init Driver, patch 206 ; Sep 26, 2023@09:50:23
;;5.0;Radiology/Nuclear Medicine;**206**;Mar 16, 1998;Build 8
;
;Supported IA #1571 ^LEX(757.01
;
BIRADS ;updates to BIRADS
;Add New codes
N RAFDA,RADNUM,RAI,RADX,RA001,RA01,RA2,RA3,RA4,RAMSG
F RAI=1:1 S RADX=$T(CODES+RAI) Q:RADX="" D
.S RA001=$P($P(RADX,";",3),"^"),RA01=$P($P(RADX,";",3),"^",2),RA2=$P($P(RADX,";",3),"^",3),RA3=$P($P(RADX,";",3),"^",4),RA4=$P($P(RADX,";",3),"^",5)
.Q:RA001=""
.S RAFDA(78.3,"+1,",.01)=RA01 ; DIAG CODE
.S RAFDA(78.3,"+1,",2)=RA2 ; DIAG DESC
.S RAFDA(78.3,"+1,",3)=RA3 ; PRINT ON ABN REPORT
.S RAFDA(78.3,"+1,",4)=RA4 ; GENERATE ALERT
.S:RA001=1110 RAFDA(78.3,"+1,",100)="Incomplete: Need prior mammograms for comparison" ;DISPLAY TEXT
.S RADNUM(1)=RA001
.D UPDATE^DIE("","RAFDA","RADNUM","RAMSG")
.;Capture any "DIERR" messages - they will tell us if an IEN already existed. They shouldn't but you never know.
.I $D(RAMSG("DIERR")) D
..S RATXT(1)="Error filing BI-RADS code "_RA001 D BMES^XPDUTL(.RATXT)
..Q
.Q
;
ABN ;Set "Print on Abnormal Report" field for 1101 and 1102
N RAIENS,RADX F RADX=1101,1102 D
.S RAIENS=RADX_","
.S RAFDA(78.3,RAIENS,3)="Y" ; PRINT ON ABN REPORT
.K RAERR D FILE^DIE("E","RAFDA","RAERR")
.I $D(RAERR("DIERR")) S RATXT(1)="Error updating BIRAD code "_RADX
.I $G(RATXT(1))="" S RATXT(1)=RADX_" Updated"
.D BMES^XPDUTL(.RATXT)
.K RAERR,RATXT
.Q
;
EXP ;Expression field update (data type changed from 757.01 pointer to free text).
N RADX,RAEXP
F RADX=1100:1:1106 D
.S RAEXP=$P(^RA(78.3,RADX,0),U,6) Q:$G(RAEXP)=""!($G(RAEXP)'?2N)
.S $P(^RA(78.3,RADX,1),U)=$$GET1^DIQ(757.01,RAEXP,.01)
.Q
Q
CODES ; NUMBER^CODE^DESC^PRINT^ALERT
;;1107^BI-RADS R^Post-Procedure Mammogram for Marker Placement^Y^n
;;1110^BI-RADS CATEGORY 0^Incomplete: Need Prior Mammograms for Comparison^Y^y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAIPS206 1902 printed Dec 13, 2024@02:36:23 Page 2
RAIPS206 ;WOIFO/KLM - Post-init Driver, patch 206 ; Sep 26, 2023@09:50:23
+1 ;;5.0;Radiology/Nuclear Medicine;**206**;Mar 16, 1998;Build 8
+2 ;
+3 ;Supported IA #1571 ^LEX(757.01
+4 ;
BIRADS ;updates to BIRADS
+1 ;Add New codes
+2 NEW RAFDA,RADNUM,RAI,RADX,RA001,RA01,RA2,RA3,RA4,RAMSG
+3 FOR RAI=1:1
SET RADX=$TEXT(CODES+RAI)
if RADX=""
QUIT
Begin DoDot:1
+4 SET RA001=$PIECE($PIECE(RADX,";",3),"^")
SET RA01=$PIECE($PIECE(RADX,";",3),"^",2)
SET RA2=$PIECE($PIECE(RADX,";",3),"^",3)
SET RA3=$PIECE($PIECE(RADX,";",3),"^",4)
SET RA4=$PIECE($PIECE(RADX,";",3),"^",5)
+5 if RA001=""
QUIT
+6 ; DIAG CODE
SET RAFDA(78.3,"+1,",.01)=RA01
+7 ; DIAG DESC
SET RAFDA(78.3,"+1,",2)=RA2
+8 ; PRINT ON ABN REPORT
SET RAFDA(78.3,"+1,",3)=RA3
+9 ; GENERATE ALERT
SET RAFDA(78.3,"+1,",4)=RA4
+10 ;DISPLAY TEXT
if RA001=1110
SET RAFDA(78.3,"+1,",100)="Incomplete: Need prior mammograms for comparison"
+11 SET RADNUM(1)=RA001
+12 DO UPDATE^DIE("","RAFDA","RADNUM","RAMSG")
+13 ;Capture any "DIERR" messages - they will tell us if an IEN already existed. They shouldn't but you never know.
+14 IF $DATA(RAMSG("DIERR"))
Begin DoDot:2
+15 SET RATXT(1)="Error filing BI-RADS code "_RA001
DO BMES^XPDUTL(.RATXT)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 ;
ABN ;Set "Print on Abnormal Report" field for 1101 and 1102
+1 NEW RAIENS,RADX
FOR RADX=1101,1102
Begin DoDot:1
+2 SET RAIENS=RADX_","
+3 ; PRINT ON ABN REPORT
SET RAFDA(78.3,RAIENS,3)="Y"
+4 KILL RAERR
DO FILE^DIE("E","RAFDA","RAERR")
+5 IF $DATA(RAERR("DIERR"))
SET RATXT(1)="Error updating BIRAD code "_RADX
+6 IF $GET(RATXT(1))=""
SET RATXT(1)=RADX_" Updated"
+7 DO BMES^XPDUTL(.RATXT)
+8 KILL RAERR,RATXT
+9 QUIT
End DoDot:1
+10 ;
EXP ;Expression field update (data type changed from 757.01 pointer to free text).
+1 NEW RADX,RAEXP
+2 FOR RADX=1100:1:1106
Begin DoDot:1
+3 SET RAEXP=$PIECE(^RA(78.3,RADX,0),U,6)
if $GET(RAEXP)=""!($GET(RAEXP)'?2N)
QUIT
+4 SET $PIECE(^RA(78.3,RADX,1),U)=$$GET1^DIQ(757.01,RAEXP,.01)
+5 QUIT
End DoDot:1
+6 QUIT
CODES ; NUMBER^CODE^DESC^PRINT^ALERT
+1 ;;1107^BI-RADS R^Post-Procedure Mammogram for Marker Placement^Y^n
+2 ;;1110^BI-RADS CATEGORY 0^Incomplete: Need Prior Mammograms for Comparison^Y^y
