MAGQAI ;WOIFO/RMP Imaging Utilities to support Assigning Initials [ 06/20/2001 08:57 ]
;;3.0;IMAGING;;Mar 01, 2002
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
;ASSIGN INITIALS FOR TELNETED IMAGING FILES
Q
ONE(DOMAIN) ;ADD A SINGLE DOMAIN
N INIT
S INIT=$$ASSN(DOMAIN)
S:INIT="" INIT=$$REASS(DOMAIN)
D:INIT'="" FINIT(DOMAIN,INIT)
Q INIT
FINIT(DOMAIN,INIT) ;File Initials
N DIC
S DIC="^MAG(2006.19,"
S X=DOMAIN,DIC("DR")=".02///^S X=INIT"
S DIC(0)="LQ" K DD,DO D FILE^DICN
Q
ASSN(VALUE) ;ASSIGN INITIALS WHILE UNIQUE
N INIT,NAME
S NAME=$P(VALUE,".")
I NAME["-" S INIT=$E(NAME,1,1)_$E($P(NAME,"-",2),1,1)
I NAME'["-" S INIT=$E(NAME,1,2)
Q $S($D(^MAG(2006.19,"C",INIT)):"",1:INIT)
REASS(REP) ;ASSIGN WITH ALTERNATE
N INIT,NAME,LEN,SEC,I,TEMP
S NAME=$P(REP,"."),INIT=""
S:NAME["-" SEC=$P(REP,"-",2)
S LEN=$S(NAME["-":$L(SEC),1:$L(NAME))
F I=1:1:LEN D Q:INIT'=""
. S TEMP=$E(NAME)_$E($S(NAME["-":SEC,1:NAME),I)
. Q:$E(TEMP,2)'?1A
. S:'$D(^MAG(2006.19,"C",TEMP)) INIT=TEMP
Q INIT
DEL ;
N INDX
S INDX=0
F S INDX=$O(^MAG(2006.19,INDX)) Q:INDX'?1N.N D
. Q:"^40^41^42^43^44^45^46^53^78^81^94^132^"[("^"_INDX_"^")
. Q:"^136^137^151^152^157^171^180^203^208^328^329^330^"[("^"_INDX_"^")
. S DA=INDX,DR=".01///@",DIE="^MAG(2006.19,"
. D ^DIE
Q
MMGRP ;CREATES REMOTE MAIL GROUP TO HANDLE IMAGE ERROR MESSAGES
N DA,DIE,DR,MAGA,MAGB,MAGC,MAGD,MAGE,MAGF,MAGG,IEN,MAGY,MAGM
;
S MAGA="MAG SERVER" ; Mail group name
S IEN=$$FIND1^DIC(3.8,"","MX",MAGA,"","","ERR")
I +IEN=0 D
. S MAGDATA(1)=""
. S MAGDATA(2)="Creating the MAG SERVER mail group."
. D MES^XPDUTL(.MAGDATA) K MAGDATA
. S MAGB=0 ; Public
. S MAGC=.5 ; Organizer is Postmaster
. S MAGD=1 ; Self enrollment
. S MAGF(1)="Mail group to manage Image activity messages." ;Description
. S MAGG=1 ; Silent flag
. S MAGDATA=$$MG^XMBGRP(MAGA,MAGB,MAGC,MAGD,.MAGE,.MAGF,MAGG)
S MAGDATA=$S(+IEN>0:IEN,MAGDATA>0:MAGDATA,1:0)
I MAGDATA>0 D
. S MAGY(DUZ)=""
. S MAGG=1
. ;ADD installer as local mail recipient
. S IEN=$$MG^XMBGRP(MAGDATA,"","","",.MAGY,"",MAGG)
. ;Add G.MAG SERVER @ development site as remote recipient
. S MAGM="G.IMAGING DEVELOPMENT TEAM@FORUM.DOMAIN.EXT"
. I '$$FIND1^DIC(3.812,","_MAGDATA_",","MX",MAGM,"","","ERR") D
. . S MAGE(3.812,"+1,"_MAGDATA_",",.01)=MAGM
. . D UPDATE^DIE("E","MAGE")
. ;Remove development domain mailgroup reference
. S MAGX=$E("G.MAG SERVER@LAVC.ISC-WASH.DOMAIN.EXT",1,30)
. S IEN=$$FIND1^DIC(3.812,","_MAGDATA_",","MX",MAGX,"","","ERR")
. I +IEN>0 D
. . K MAGE
. . S MAGE(3.812,IEN_","_MAGDATA_",",.01)="@"
. . D UPDATE^DIE("E","MAGE")
Q
JBPTR() ;
N JBPTR,X
S U="^"
S JBPTR=$S($P(^MAG(2006.1,1,1),U,6)>1:$P(^(1),U,6),+$P($G(^MAGQUEUE(2006.032,0)),U,4):$P(^(0),U,4),1:1)
S X=$G(^MAGQUEUE(2006.032,JBPTR,0))
Q $S(X="":0,1:JBPTR)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQAI 3813 printed Dec 13, 2024@02:07:41 Page 2
MAGQAI ;WOIFO/RMP Imaging Utilities to support Assigning Initials [ 06/20/2001 08:57 ]
+1 ;;3.0;IMAGING;;Mar 01, 2002
+2 ;; +---------------------------------------------------------------+
+3 ;; | Property of the US Government. |
+4 ;; | No permission to copy or redistribute this software is given. |
+5 ;; | Use of unreleased versions of this software requires the user |
+6 ;; | to execute a written test agreement with the VistA Imaging |
+7 ;; | Development Office of the Department of Veterans Affairs, |
+8 ;; | telephone (301) 734-0100. |
+9 ;; | |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ;ASSIGN INITIALS FOR TELNETED IMAGING FILES
+18 QUIT
ONE(DOMAIN) ;ADD A SINGLE DOMAIN
+1 NEW INIT
+2 SET INIT=$$ASSN(DOMAIN)
+3 if INIT=""
SET INIT=$$REASS(DOMAIN)
+4 if INIT'=""
DO FINIT(DOMAIN,INIT)
+5 QUIT INIT
FINIT(DOMAIN,INIT) ;File Initials
+1 NEW DIC
+2 SET DIC="^MAG(2006.19,"
+3 SET X=DOMAIN
SET DIC("DR")=".02///^S X=INIT"
+4 SET DIC(0)="LQ"
KILL DD,DO
DO FILE^DICN
+5 QUIT
ASSN(VALUE) ;ASSIGN INITIALS WHILE UNIQUE
+1 NEW INIT,NAME
+2 SET NAME=$PIECE(VALUE,".")
+3 IF NAME["-"
SET INIT=$EXTRACT(NAME,1,1)_$EXTRACT($PIECE(NAME,"-",2),1,1)
+4 IF NAME'["-"
SET INIT=$EXTRACT(NAME,1,2)
+5 QUIT $SELECT($DATA(^MAG(2006.19,"C",INIT)):"",1:INIT)
REASS(REP) ;ASSIGN WITH ALTERNATE
+1 NEW INIT,NAME,LEN,SEC,I,TEMP
+2 SET NAME=$PIECE(REP,".")
SET INIT=""
+3 if NAME["-"
SET SEC=$PIECE(REP,"-",2)
+4 SET LEN=$SELECT(NAME["-":$LENGTH(SEC),1:$LENGTH(NAME))
+5 FOR I=1:1:LEN
Begin DoDot:1
+6 SET TEMP=$EXTRACT(NAME)_$EXTRACT($SELECT(NAME["-":SEC,1:NAME),I)
+7 if $EXTRACT(TEMP,2)'?1A
QUIT
+8 if '$DATA(^MAG(2006.19,"C",TEMP))
SET INIT=TEMP
End DoDot:1
if INIT'=""
QUIT
+9 QUIT INIT
DEL ;
+1 NEW INDX
+2 SET INDX=0
+3 FOR
SET INDX=$ORDER(^MAG(2006.19,INDX))
if INDX'?1N.N
QUIT
Begin DoDot:1
+4 if "^40^41^42^43^44^45^46^53^78^81^94^132^"[("^"_INDX_"^")
QUIT
+5 if "^136^137^151^152^157^171^180^203^208^328^329^330^"[("^"_INDX_"^")
QUIT
+6 SET DA=INDX
SET DR=".01///@"
SET DIE="^MAG(2006.19,"
+7 DO ^DIE
End DoDot:1
+8 QUIT
MMGRP ;CREATES REMOTE MAIL GROUP TO HANDLE IMAGE ERROR MESSAGES
+1 NEW DA,DIE,DR,MAGA,MAGB,MAGC,MAGD,MAGE,MAGF,MAGG,IEN,MAGY,MAGM
+2 ;
+3 ; Mail group name
SET MAGA="MAG SERVER"
+4 SET IEN=$$FIND1^DIC(3.8,"","MX",MAGA,"","","ERR")
+5 IF +IEN=0
Begin DoDot:1
+6 SET MAGDATA(1)=""
+7 SET MAGDATA(2)="Creating the MAG SERVER mail group."
+8 DO MES^XPDUTL(.MAGDATA)
KILL MAGDATA
+9 ; Public
SET MAGB=0
+10 ; Organizer is Postmaster
SET MAGC=.5
+11 ; Self enrollment
SET MAGD=1
+12 ;Description
SET MAGF(1)="Mail group to manage Image activity messages."
+13 ; Silent flag
SET MAGG=1
+14 SET MAGDATA=$$MG^XMBGRP(MAGA,MAGB,MAGC,MAGD,.MAGE,.MAGF,MAGG)
End DoDot:1
+15 SET MAGDATA=$SELECT(+IEN>0:IEN,MAGDATA>0:MAGDATA,1:0)
+16 IF MAGDATA>0
Begin DoDot:1
+17 SET MAGY(DUZ)=""
+18 SET MAGG=1
+19 ;ADD installer as local mail recipient
+20 SET IEN=$$MG^XMBGRP(MAGDATA,"","","",.MAGY,"",MAGG)
+21 ;Add G.MAG SERVER @ development site as remote recipient
+22 SET MAGM="G.IMAGING DEVELOPMENT TEAM@FORUM.DOMAIN.EXT"
+23 IF '$$FIND1^DIC(3.812,","_MAGDATA_",","MX",MAGM,"","","ERR")
Begin DoDot:2
+24 SET MAGE(3.812,"+1,"_MAGDATA_",",.01)=MAGM
+25 DO UPDATE^DIE("E","MAGE")
End DoDot:2
+26 ;Remove development domain mailgroup reference
+27 SET MAGX=$EXTRACT("G.MAG SERVER@LAVC.ISC-WASH.DOMAIN.EXT",1,30)
+28 SET IEN=$$FIND1^DIC(3.812,","_MAGDATA_",","MX",MAGX,"","","ERR")
+29 IF +IEN>0
Begin DoDot:2
+30 KILL MAGE
+31 SET MAGE(3.812,IEN_","_MAGDATA_",",.01)="@"
+32 DO UPDATE^DIE("E","MAGE")
End DoDot:2
End DoDot:1
+33 QUIT
JBPTR() ;
+1 NEW JBPTR,X
+2 SET U="^"
+3 SET JBPTR=$SELECT($PIECE(^MAG(2006.1,1,1),U,6)>1:$PIECE(^(1),U,6),+$PIECE($GET(^MAGQUEUE(2006.032,0)),U,4):$PIECE(^(0),U,4),1:1)
+4 SET X=$GET(^MAGQUEUE(2006.032,JBPTR,0))
+5 QUIT $SELECT(X="":0,1:JBPTR)
