RAIPS158 ;HISC/GJC post-install routine ;05 Jun 2019 8:37 AM
;;5.0;Radiology/Nuclear Medicine;**158**;Mar 16, 1998;Build 2
;
;Routine IA Type
;-------------------------------------
; ^%ZTLOAD 10063 (S)
; FILE^DIE 2053 (S)
; DT^XLFDT 10103 (S)
; FMADD^XLFDT 10103 (S)
; UNWIND^%ZTER 1621 (S)
; ^%ZTER 1621 (S)
; FILESEC^DDMOD 2916 (S)
; DQ^XUFILE1 7078 (P)
;
N RACHX1 S RACHX1=$$NEWCP^XPDUTL("POST1","EN^RAIPS158")
Q
;
EN ;delete the ORIGINAL PROCEDURE? (field: [#8]) flag
; for all procedures in the RAD/NUC MED PROCEDURES [#71]
; file.
;
; ^XTMP(namespaced- subscript,0)=purge date^create date^last file 71 IEN
; (both dates will be in VA FileMan internal date format). TTL = fifteen days
;
I '$D(^XTMP("RA158",0))#2 D
.S ^XTMP("RA158",0)=$$FMADD^XLFDT($$DT^XLFDT(),15,0,0,0)_U_$$DT^XLFDT()_U
.Q
;
K RATXT,RAY N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S RAY=+$P($G(^XTMP("RA158",0)),U,3)
S:RAY>0 RAY=(RAY-0.1)
S ZTIO="",ZTRTN="EN1^RAIPS158",ZTSAVE("RAY")=""
S (ZTDESC,RATXT(1))="RA158 post: Delete the ORIGINAL PROCEDURE? flag from file [#71]."
S ZTDTH=$H D ^%ZTLOAD
S RATXT(2)="Task: "_$S($G(ZTSK)>0:ZTSK,1:"in error")
D BMES^XPDUTL(.RATXT) K RATXT,RAY
;
D EN2 ;add new cancel reasons to file 75.2
;
D EN3 ;remove TYPE OF REASON value for all non-national records in file 75.2
;
D EN4 ;remove user access to the RAD/NUC MED REASON [#75.2]
;
D EN5 ;set file security for 75.2 all "@" except for "RD" & "AUDIT"
;
QUIT
;
EN1 ; entry point to loop [#71] called from EN tag.
;
N $ESTACK,$ETRAP S $ETRAP="D ABEND^RAIPS158"
;
S RAROOT=$NA(^RAMIS(71))
;variable RAY set above
F S RAY=$O(^RAMIS(71,RAY)) Q:RAY'>0 D
.Q:$P(@RAROOT@(RAY,0),U,8)'="Y"
.S RAFDA(71,RAY_",",8)="@" D FILE^DIE("","RAFDA")
.K RAFDA S $P(^XTMP("RA158",0),U,3)=RAY
.Q
K RAROOT,RAY
S:$D(ZTQUEUED)#2 ZTREQ="@"
Q
;
ABEND ;come here on error
S $P(^XTMP("RA158",0),U,3)=$G(RAY)
D ^%ZTER ; record the error
D UNWIND^%ZTER ; unwind the stack, return to caller.
Q
;
EN2 ;add new cancel reasons...
S RAR="RAFDA(75.2,""?+1,"")" ;FDA root - check for existing entry w/?
F RAI=1:1 S RAREA=$T(REA+RAI) Q:RAREA="" D
.S RA01=$P(RAREA,";",3),RA3=$P(RAREA,";",4)
.S @RAR@(.01)=RA01 ;Reason
.S @RAR@(2)=1 ;Type of reason=cancel request
.S @RAR@(3)=RA3 ;Synonym
.S @RAR@(4)="i" ;Nature of order activity=Policy
.S @RAR@(5)="Y" ;NATIONAL flag = YES prevents local modifications
.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
K RAI,RAR,RAREA
Q
;
EN3 ;remove type of reason (#2) off non-national reason
S RAY=0 F S RAY=$O(^RA(75.2,RAY)) Q:RAY'>0 D
.Q:$P(^RA(75.2,RAY,0),U,5)="Y" ;national - hands off
.S RAFDA(75.2,RAY_",",2)="@"
.D FILE^DIE("","RAFDA","")
.K RAFDA
.Q
K RAY
Q
;
EN4 ;remove user access to the RAD/NUC MED REASON [#75.2]
N RATXT,ZTDESC,ZTDTH,ZTIO,ZTRTN
S ZTIO="",RATXT(1)="",ZTRTN="TSK^RAIPS158"
S (ZTDESC,RATXT(2))="RA158: remove user access to the RAD/NUC MED REASON [#75.2]"
S ZTDTH=$H D ^%ZTLOAD S RATXT(3)="Task: "_$S($G(ZTSK)>0:ZTSK,1:"in error")
D BMES^XPDUTL(.RATXT)
Q
;
EN5 ;set file security for 75.2 all "@" except for "RD" & "AUDIT"
K ^TMP("DIERR",$J)
S RASEC752("DD")="@"
S RASEC752("RD")=""
S RASEC752("WR")="@"
S RASEC752("DEL")="@"
S RASEC752("LAYGO")="@"
S RASEC752("AUDIT")=""
D FILESEC^DDMOD(75.2,.RASEC752)
I $D(^TMP("DIERR",$J))>0 K RATXT D
.S RATXT(1)="Error when setting security access codes for the"
.S RATXT(2)="RAD/NUC MED REASON [#75.2] file." D BMES^XPDUTL(.RATXT)
.K RATXT
.Q
K ^TMP("DIERR",$J),RASEC752
Q
;
TSK ;remove user access to the RAD/NUC MED REASON [#75.2]
;file.
N XUW S XUW=75.2 D DQ^XUFILE1
Q
;
;Note: type of reason = cancel request; Nature of order = policy; national = yes
REA ;reason table
;;CC-IMAGING CONSULT DC/ADMIN CLOSURE POLICY;CC ADMIN CLOSE
;;CC-IMAGING CONSULT DC PT CX'D;CC CANCEL
;;CC-IMAGING CONSULT DC PT NO SHOW;CC NO SHOW
;;CC-IMAGING CONSULT DC UNABLE TO CONTACT;CC NO RESPONSE
;;OBSOLETE ORDER;OBSOLETE
;;UNABLE TO CONTACT THE PATIENT;NO RESPONSE
;;FUTURE DD/CID GREATER THAN 390 DAYS;FUTURE > 390
;;PATIENT NO SHOWED;NO SHOW
;;DUPLICATE ORDER;DUPLICATE
;;PATIENT REFUSED;REFUSED EXAM
;;EXAM CANCELLED;EXAM CANCELLED
;;OTHER;OTHER
;;IMAGES UNAVAILABLE;NO IMAGES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAIPS158 4661 printed Apr 09, 2024@21:39:44 Page 2
RAIPS158 ;HISC/GJC post-install routine ;05 Jun 2019 8:37 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**158**;Mar 16, 1998;Build 2
+2 ;
+3 ;Routine IA Type
+4 ;-------------------------------------
+5 ; ^%ZTLOAD 10063 (S)
+6 ; FILE^DIE 2053 (S)
+7 ; DT^XLFDT 10103 (S)
+8 ; FMADD^XLFDT 10103 (S)
+9 ; UNWIND^%ZTER 1621 (S)
+10 ; ^%ZTER 1621 (S)
+11 ; FILESEC^DDMOD 2916 (S)
+12 ; DQ^XUFILE1 7078 (P)
+13 ;
+14 NEW RACHX1
SET RACHX1=$$NEWCP^XPDUTL("POST1","EN^RAIPS158")
+15 QUIT
+16 ;
EN ;delete the ORIGINAL PROCEDURE? (field: [#8]) flag
+1 ; for all procedures in the RAD/NUC MED PROCEDURES [#71]
+2 ; file.
+3 ;
+4 ; ^XTMP(namespaced- subscript,0)=purge date^create date^last file 71 IEN
+5 ; (both dates will be in VA FileMan internal date format). TTL = fifteen days
+6 ;
+7 IF '$DATA(^XTMP("RA158",0))#2
Begin DoDot:1
+8 SET ^XTMP("RA158",0)=$$FMADD^XLFDT($$DT^XLFDT(),15,0,0,0)_U_$$DT^XLFDT()_U
+9 QUIT
End DoDot:1
+10 ;
+11 KILL RATXT,RAY
NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+12 SET RAY=+$PIECE($GET(^XTMP("RA158",0)),U,3)
+13 if RAY>0
SET RAY=(RAY-0.1)
+14 SET ZTIO=""
SET ZTRTN="EN1^RAIPS158"
SET ZTSAVE("RAY")=""
+15 SET (ZTDESC,RATXT(1))="RA158 post: Delete the ORIGINAL PROCEDURE? flag from file [#71]."
+16 SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+17 SET RATXT(2)="Task: "_$SELECT($GET(ZTSK)>0:ZTSK,1:"in error")
+18 DO BMES^XPDUTL(.RATXT)
KILL RATXT,RAY
+19 ;
+20 ;add new cancel reasons to file 75.2
DO EN2
+21 ;
+22 ;remove TYPE OF REASON value for all non-national records in file 75.2
DO EN3
+23 ;
+24 ;remove user access to the RAD/NUC MED REASON [#75.2]
DO EN4
+25 ;
+26 ;set file security for 75.2 all "@" except for "RD" & "AUDIT"
DO EN5
+27 ;
+28 QUIT
+29 ;
EN1 ; entry point to loop [#71] called from EN tag.
+1 ;
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D ABEND^RAIPS158"
+3 ;
+4 SET RAROOT=$NAME(^RAMIS(71))
+5 ;variable RAY set above
+6 FOR
SET RAY=$ORDER(^RAMIS(71,RAY))
if RAY'>0
QUIT
Begin DoDot:1
+7 if $PIECE(@RAROOT@(RAY,0),U,8)'="Y"
QUIT
+8 SET RAFDA(71,RAY_",",8)="@"
DO FILE^DIE("","RAFDA")
+9 KILL RAFDA
SET $PIECE(^XTMP("RA158",0),U,3)=RAY
+10 QUIT
End DoDot:1
+11 KILL RAROOT,RAY
+12 if $DATA(ZTQUEUED)#2
SET ZTREQ="@"
+13 QUIT
+14 ;
ABEND ;come here on error
+1 SET $PIECE(^XTMP("RA158",0),U,3)=$GET(RAY)
+2 ; record the error
DO ^%ZTER
+3 ; unwind the stack, return to caller.
DO UNWIND^%ZTER
+4 QUIT
+5 ;
EN2 ;add new cancel reasons...
+1 ;FDA root - check for existing entry w/?
SET RAR="RAFDA(75.2,""?+1,"")"
+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)
+4 ;Reason
SET @RAR@(.01)=RA01
+5 ;Type of reason=cancel request
SET @RAR@(2)=1
+6 ;Synonym
SET @RAR@(3)=RA3
+7 ;Nature of order activity=Policy
SET @RAR@(4)="i"
+8 ;NATIONAL flag = YES prevents local modifications
SET @RAR@(5)="Y"
+9 DO UPDATE^DIE(,"RAFDA","","RAMSG(1)")
KILL RAFDA
+10 IF $DATA(RAMSG(1,"DIERR"))#2
SET RATXT="An error occured filing data for "_RA01
+11 IF '$TEST
SET RATXT=RA01_" filed"
+12 DO MES^XPDUTL(RATXT)
+13 KILL RATXT,RAMSG
End DoDot:1
+14 KILL RAI,RAR,RAREA
+15 QUIT
+16 ;
EN3 ;remove type of reason (#2) off non-national reason
+1 SET RAY=0
FOR
SET RAY=$ORDER(^RA(75.2,RAY))
if RAY'>0
QUIT
Begin DoDot:1
+2 ;national - hands off
if $PIECE(^RA(75.2,RAY,0),U,5)="Y"
QUIT
+3 SET RAFDA(75.2,RAY_",",2)="@"
+4 DO FILE^DIE("","RAFDA","")
+5 KILL RAFDA
+6 QUIT
End DoDot:1
+7 KILL RAY
+8 QUIT
+9 ;
EN4 ;remove user access to the RAD/NUC MED REASON [#75.2]
+1 NEW RATXT,ZTDESC,ZTDTH,ZTIO,ZTRTN
+2 SET ZTIO=""
SET RATXT(1)=""
SET ZTRTN="TSK^RAIPS158"
+3 SET (ZTDESC,RATXT(2))="RA158: remove user access to the RAD/NUC MED REASON [#75.2]"
+4 SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
SET RATXT(3)="Task: "_$SELECT($GET(ZTSK)>0:ZTSK,1:"in error")
+5 DO BMES^XPDUTL(.RATXT)
+6 QUIT
+7 ;
EN5 ;set file security for 75.2 all "@" except for "RD" & "AUDIT"
+1 KILL ^TMP("DIERR",$JOB)
+2 SET RASEC752("DD")="@"
+3 SET RASEC752("RD")=""
+4 SET RASEC752("WR")="@"
+5 SET RASEC752("DEL")="@"
+6 SET RASEC752("LAYGO")="@"
+7 SET RASEC752("AUDIT")=""
+8 DO FILESEC^DDMOD(75.2,.RASEC752)
+9 IF $DATA(^TMP("DIERR",$JOB))>0
KILL RATXT
Begin DoDot:1
+10 SET RATXT(1)="Error when setting security access codes for the"
+11 SET RATXT(2)="RAD/NUC MED REASON [#75.2] file."
DO BMES^XPDUTL(.RATXT)
+12 KILL RATXT
+13 QUIT
End DoDot:1
+14 KILL ^TMP("DIERR",$JOB),RASEC752
+15 QUIT
+16 ;
TSK ;remove user access to the RAD/NUC MED REASON [#75.2]
+1 ;file.
+2 NEW XUW
SET XUW=75.2
DO DQ^XUFILE1
+3 QUIT
+4 ;
+5 ;Note: type of reason = cancel request; Nature of order = policy; national = yes
REA ;reason table
+1 ;;CC-IMAGING CONSULT DC/ADMIN CLOSURE POLICY;CC ADMIN CLOSE
+2 ;;CC-IMAGING CONSULT DC PT CX'D;CC CANCEL
+3 ;;CC-IMAGING CONSULT DC PT NO SHOW;CC NO SHOW
+4 ;;CC-IMAGING CONSULT DC UNABLE TO CONTACT;CC NO RESPONSE
+5 ;;OBSOLETE ORDER;OBSOLETE
+6 ;;UNABLE TO CONTACT THE PATIENT;NO RESPONSE
+7 ;;FUTURE DD/CID GREATER THAN 390 DAYS;FUTURE > 390
+8 ;;PATIENT NO SHOWED;NO SHOW
+9 ;;DUPLICATE ORDER;DUPLICATE
+10 ;;PATIENT REFUSED;REFUSED EXAM
+11 ;;EXAM CANCELLED;EXAM CANCELLED
+12 ;;OTHER;OTHER
+13 ;;IMAGES UNAVAILABLE;NO IMAGES
