RAIPS191 ;WOIFO/KLM - PostInit 191 ; Jun 02, 2022@06:46:05
;;5.0;Radiology/Nuclear Medicine;**191**;Mar 16, 1998;Build 1
;
; This post-install routine will add a Contrast Shortage cancel/hold reason
; in the RAD/NUC MED REASON file (#75.2)
;
; Reference to UPDATE^DIE in ICR #2053
; Reference to MES^XPDUTL in ICR #10141
;
EN ;entry point
N RAI,RAREA,RAMSG,RATXT,RAMSG,RA01,RA2,RA3
F RAI=1:1 S RAREA=$T(REA+RAI) Q:RAREA="" D
.S RA01=$P(RAREA,";",3),RA3=$P(RAREA,";",4),RA2=$P(RAREA,";",5)
.N RAFDA,RAR S RAR="RAFDA(75.2,""?+1,"")" ;FDA root - ? checks for existing record
.S @RAR@(.01)=RA01 ;Reason
.S @RAR@(2)=RA2 ;Type of reason (1=cancel,3=hold,9=general)
.S @RAR@(3)=RA3 ;Synonym
.S @RAR@(4)="i" ;Nature of order activity=Policy
.S @RAR@(5)="Y" ;NATIONAL flag = YES
.D UPDATE^DIE(,"RAFDA","","RAMSG(1)") K RAFDA
.I $D(RAMSG(1,"DIERR"))#2 S RATXT="An error occured filing data for "_RA01
.E S RATXT=RA01_" filed"
.D MES^XPDUTL(RATXT) K RATXT,RAMSG
Q
REA ;REASON;SYNONYM;TYPE OF REASON
;;GLOBAL CONTRAST SHORTAGE;SHORTAGE;9
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAIPS191 1094 printed Nov 22, 2024@17:46:15 Page 2
RAIPS191 ;WOIFO/KLM - PostInit 191 ; Jun 02, 2022@06:46:05
+1 ;;5.0;Radiology/Nuclear Medicine;**191**;Mar 16, 1998;Build 1
+2 ;
+3 ; This post-install routine will add a Contrast Shortage cancel/hold reason
+4 ; in the RAD/NUC MED REASON file (#75.2)
+5 ;
+6 ; Reference to UPDATE^DIE in ICR #2053
+7 ; Reference to MES^XPDUTL in ICR #10141
+8 ;
EN ;entry point
+1 NEW RAI,RAREA,RAMSG,RATXT,RAMSG,RA01,RA2,RA3
+2 FOR RAI=1:1
SET RAREA=$TEXT(REA+RAI)
if RAREA=""
QUIT
Begin DoDot:1
+3 SET RA01=$PIECE(RAREA,";",3)
SET RA3=$PIECE(RAREA,";",4)
SET RA2=$PIECE(RAREA,";",5)
+4 ;FDA root - ? checks for existing record
NEW RAFDA,RAR
SET RAR="RAFDA(75.2,""?+1,"")"
+5 ;Reason
SET @RAR@(.01)=RA01
+6 ;Type of reason (1=cancel,3=hold,9=general)
SET @RAR@(2)=RA2
+7 ;Synonym
SET @RAR@(3)=RA3
+8 ;Nature of order activity=Policy
SET @RAR@(4)="i"
+9 ;NATIONAL flag = YES
SET @RAR@(5)="Y"
+10 DO UPDATE^DIE(,"RAFDA","","RAMSG(1)")
KILL RAFDA
+11 IF $DATA(RAMSG(1,"DIERR"))#2
SET RATXT="An error occured filing data for "_RA01
+12 IF '$TEST
SET RATXT=RA01_" filed"
+13 DO MES^XPDUTL(RATXT)
KILL RATXT,RAMSG
End DoDot:1
+14 QUIT
REA ;REASON;SYNONYM;TYPE OF REASON
+1 ;;GLOBAL CONTRAST SHORTAGE;SHORTAGE;9
