- 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 Feb 19, 2025@00:02:19 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