Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAIPS158

RAIPS158.m

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