RAACIPST ;HISC/CAH - postinit for patch 8 ;10/23/96 16:26
;;4.5;Radiology/Nuclear Medicine;**8**;Dec 12, 1995
EN1 ;For each imaging loc, get file 44 pointer, DSS ID, Div
;and give to MAS to set/reset params on the file 44 entry
N RA791,RA44,RA44NM,RA44NM2,RADSS,RADSSNM,RADIV,RAERRCNT,RA44NEW,RATRY
S RA791=0 F S RA791=$O(^RA(79.1,RA791)) Q:'RA791 D
. S RAERRCNT=0,RA44NM2=""
. S RA791(0)=$G(^RA(79.1,+RA791,0))
. S RA44=$P(RA791(0),"^",1) I '$D(^SC(+RA44,0)) D ERR44
. S RA44NM=$P($G(^SC(+RA44,0)),"^",1)
. S RADSS=$P(RA791(0),"^",22) I 'RADSS D ERRDSS
. S RADSSNM=$P($G(^DIC(40.7,+RADSS,0)),"^",2)
. S RADIV=$G(^RA(79.1,+RA791,"DIV")) I 'RADIV D ERRDIV
. I RAERRCNT Q ;If this Img Loc has an error, stop here
. ;Call MAS Sched'g routine with img loc data
. S RA44NEW=$$RAD^SCDXUAPI(RA44,"RA") ;returns ien of same or new loc
. I +RA44NEW=-1 D ERRMSG(RA44NEW) Q ; explain why $$RAD call failed
. I RA44NEW'=RA44 D REPOINT
. S RATRY=$$LOC^SCDXUAPI($S($L(RA44NM2):RA44NM2,1:RA44NM),RADIV,RADSSNM,"RA",RA44)
. I +RATRY=-1 D ERRMSG(RATRY)
. I +RATRY'=-1 D OK
. Q
D DEL148 ; delete 'Telephone/Diagnostic' (148) Stop Code from 71.5
Q
ERR44 ;bad file 44 pointer
N TXT S RAERRCNT=RAERRCNT+1
S TXT(1)="Imaging Location file #79.1 internal entry #"_RA44
S TXT(2)="is a broken pointer to Hospital Location file #44."
S TXT(3)="IRM must resolve this problem, then the Rad/Nuc Med ADPAC"
S TXT(4)="should use the Location Parameter Set-up [RA SYSLOC] option"
S TXT(5)="to edit this Imaging Location, and the Division Parameter"
S TXT(6)="Set-up [RA SYSDIV] option to assign it to a division."
S TXT(7)=" " D MES^XPDUTL(.TXT)
Q
ERRDSS ;bad file 40.7 pointer (DSS ID/Stop Code)
N TXT S RAERRCNT=RAERRCNT+1
S TXT(1)="Imaging Location file #79.1 entry "_$S($L(RA44NM):RA44NM,1:RA44)_" has a missing or"
S TXT(2)="invalid DSS ID. The Radiology/Nuclear Medicine ADPAC should"
S TXT(3)="use the Location Parameter Set-up [RA SYSLOC] option to enter"
S TXT(4)="a valid imaging DSS Code for this imaging location."
S TXT(5)=" " D MES^XPDUTL(.TXT)
Q
ERRDIV ;bad or non-existent Division on active imaging loc
N TXT S RAERRCNT=RAERRCNT+1
S TXT(1)="Imaging Location file #79.1 entry "_$S($L(RA44NM):RA44NM,1:RA44)_" is not assigned"
S TXT(2)="to a Rad/Nuc Med Division. If Imaging exams are to be registered"
S TXT(3)="in this imaging location, or if there are incomplete exams"
S TXT(4)="already registered to this location, the Radiology/Nuclear"
S TXT(5)="Med ADPAC should use the Division Parameter Set-up [RA SYSDIV]"
S TXT(6)="option to assign this imaging location to the appropriate"
S TXT(7)="Rad/Nuc Med Division."
S TXT(8)=" " D MES^XPDUTL(.TXT)
Q
ERRMSG(RAX) ; Explain why the $$RAD call failed.
N TXT S TXT(1)="Scheduling routine could not reset Hospital Location"
S TXT(2)="file #44 params for Imaging Location "_$S($L(RA44NM2):RA44NM2,1:RA44NM)
S TXT(3)="to agree with params on the Imaging Location file #79.1."
S TXT(4)="IRM should investigate the cause of this Scheduling error message:"
S TXT(5)=" * "_$P(RAX,"^",3)_" * "
S TXT(6)=" " D MES^XPDUTL(.TXT)
Q
REPOINT ;current img loc points to a file 44 entry with appt patterns
;must be repointed to the loc Sched'g returned to us
;
;call DIE or Silent FM to change .01 fld of file 79.1 to RA44NEW
;use equivalent of /// stuff, and give a message about old imaging
;loc name changing to new name
;
N TXT,RAERR,RAFDA
S RA44=RA44NEW,RA44NM2=$P($G(^SC(+RA44NEW,0)),"^",1)
S RAFDA(79.1,RA791_",",.01)=RA44NEW
D FILE^DIE("K","RAFDA","RAERR")
S TXT(1)="Imaging Location "_RA44NM_" has appointment patterns, and"
S TXT(2)="cannot be 'pointed to' from a file 79.1 Imaging Location."
S TXT(3)="Imaging Location "_RA44NM_" has been 're-pointed' to"
S TXT(4)="Hospital Location "_RA44NM2_"."
S TXT(5)=" " D MES^XPDUTL(.TXT)
Q
OK ;this img loc was processed ok
N TXT
S TXT(1)="Imaging Location "_$S($L(RA44NM2):RA44NM2,1:RA44NM)_" is OK."
S TXT(2)=" " D MES^XPDUTL(.TXT)
Q
DEL148 ; Delete 'Telephone/Diagnostic' Stop Code from the Imaging Stop Codes
; file. Data resides in ^RAMIS(71.5,
N %,DA,DIC,DIK,I,RA407,RARRY,RASTOP,TXT,X,Y S (I,RASTOP)=0
S TXT(1)="Deleting the 'Telephone/Diagnostic' Stop Code from the"
S TXT(2)="Imaging Stop Codes (71.5) file.",TXT(3)=" "
F S I=$O(^RAMIS(71.5,I)) Q:I'>0 D Q:RASTOP
. S RA407(1)=+$P($G(^RAMIS(71.5,I,0)),"^")
. D GETS^DIQ(40.7,RA407(1)_",",1,"","RARRY")
. I $G(RARRY(40.7,RA407(1)_",",1))=148 D Q
.. S RASTOP=1,DA=I,DIK="^RAMIS(71.5," D ^DIK
.. D BMES^XPDUTL(.TXT)
.. Q
. K RARRY
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAACIPST 4663 printed Dec 13, 2024@02:33:41 Page 2
RAACIPST ;HISC/CAH - postinit for patch 8 ;10/23/96 16:26
+1 ;;4.5;Radiology/Nuclear Medicine;**8**;Dec 12, 1995
EN1 ;For each imaging loc, get file 44 pointer, DSS ID, Div
+1 ;and give to MAS to set/reset params on the file 44 entry
+2 NEW RA791,RA44,RA44NM,RA44NM2,RADSS,RADSSNM,RADIV,RAERRCNT,RA44NEW,RATRY
+3 SET RA791=0
FOR
SET RA791=$ORDER(^RA(79.1,RA791))
if 'RA791
QUIT
Begin DoDot:1
+4 SET RAERRCNT=0
SET RA44NM2=""
+5 SET RA791(0)=$GET(^RA(79.1,+RA791,0))
+6 SET RA44=$PIECE(RA791(0),"^",1)
IF '$DATA(^SC(+RA44,0))
DO ERR44
+7 SET RA44NM=$PIECE($GET(^SC(+RA44,0)),"^",1)
+8 SET RADSS=$PIECE(RA791(0),"^",22)
IF 'RADSS
DO ERRDSS
+9 SET RADSSNM=$PIECE($GET(^DIC(40.7,+RADSS,0)),"^",2)
+10 SET RADIV=$GET(^RA(79.1,+RA791,"DIV"))
IF 'RADIV
DO ERRDIV
+11 ;If this Img Loc has an error, stop here
IF RAERRCNT
QUIT
+12 ;Call MAS Sched'g routine with img loc data
+13 ;returns ien of same or new loc
SET RA44NEW=$$RAD^SCDXUAPI(RA44,"RA")
+14 ; explain why $$RAD call failed
IF +RA44NEW=-1
DO ERRMSG(RA44NEW)
QUIT
+15 IF RA44NEW'=RA44
DO REPOINT
+16 SET RATRY=$$LOC^SCDXUAPI($SELECT($LENGTH(RA44NM2):RA44NM2,1:RA44NM),RADIV,RADSSNM,"RA",RA44)
+17 IF +RATRY=-1
DO ERRMSG(RATRY)
+18 IF +RATRY'=-1
DO OK
+19 QUIT
End DoDot:1
+20 ; delete 'Telephone/Diagnostic' (148) Stop Code from 71.5
DO DEL148
+21 QUIT
ERR44 ;bad file 44 pointer
+1 NEW TXT
SET RAERRCNT=RAERRCNT+1
+2 SET TXT(1)="Imaging Location file #79.1 internal entry #"_RA44
+3 SET TXT(2)="is a broken pointer to Hospital Location file #44."
+4 SET TXT(3)="IRM must resolve this problem, then the Rad/Nuc Med ADPAC"
+5 SET TXT(4)="should use the Location Parameter Set-up [RA SYSLOC] option"
+6 SET TXT(5)="to edit this Imaging Location, and the Division Parameter"
+7 SET TXT(6)="Set-up [RA SYSDIV] option to assign it to a division."
+8 SET TXT(7)=" "
DO MES^XPDUTL(.TXT)
+9 QUIT
ERRDSS ;bad file 40.7 pointer (DSS ID/Stop Code)
+1 NEW TXT
SET RAERRCNT=RAERRCNT+1
+2 SET TXT(1)="Imaging Location file #79.1 entry "_$SELECT($LENGTH(RA44NM):RA44NM,1:RA44)_" has a missing or"
+3 SET TXT(2)="invalid DSS ID. The Radiology/Nuclear Medicine ADPAC should"
+4 SET TXT(3)="use the Location Parameter Set-up [RA SYSLOC] option to enter"
+5 SET TXT(4)="a valid imaging DSS Code for this imaging location."
+6 SET TXT(5)=" "
DO MES^XPDUTL(.TXT)
+7 QUIT
ERRDIV ;bad or non-existent Division on active imaging loc
+1 NEW TXT
SET RAERRCNT=RAERRCNT+1
+2 SET TXT(1)="Imaging Location file #79.1 entry "_$SELECT($LENGTH(RA44NM):RA44NM,1:RA44)_" is not assigned"
+3 SET TXT(2)="to a Rad/Nuc Med Division. If Imaging exams are to be registered"
+4 SET TXT(3)="in this imaging location, or if there are incomplete exams"
+5 SET TXT(4)="already registered to this location, the Radiology/Nuclear"
+6 SET TXT(5)="Med ADPAC should use the Division Parameter Set-up [RA SYSDIV]"
+7 SET TXT(6)="option to assign this imaging location to the appropriate"
+8 SET TXT(7)="Rad/Nuc Med Division."
+9 SET TXT(8)=" "
DO MES^XPDUTL(.TXT)
+10 QUIT
ERRMSG(RAX) ; Explain why the $$RAD call failed.
+1 NEW TXT
SET TXT(1)="Scheduling routine could not reset Hospital Location"
+2 SET TXT(2)="file #44 params for Imaging Location "_$SELECT($LENGTH(RA44NM2):RA44NM2,1:RA44NM)
+3 SET TXT(3)="to agree with params on the Imaging Location file #79.1."
+4 SET TXT(4)="IRM should investigate the cause of this Scheduling error message:"
+5 SET TXT(5)=" * "_$PIECE(RAX,"^",3)_" * "
+6 SET TXT(6)=" "
DO MES^XPDUTL(.TXT)
+7 QUIT
REPOINT ;current img loc points to a file 44 entry with appt patterns
+1 ;must be repointed to the loc Sched'g returned to us
+2 ;
+3 ;call DIE or Silent FM to change .01 fld of file 79.1 to RA44NEW
+4 ;use equivalent of /// stuff, and give a message about old imaging
+5 ;loc name changing to new name
+6 ;
+7 NEW TXT,RAERR,RAFDA
+8 SET RA44=RA44NEW
SET RA44NM2=$PIECE($GET(^SC(+RA44NEW,0)),"^",1)
+9 SET RAFDA(79.1,RA791_",",.01)=RA44NEW
+10 DO FILE^DIE("K","RAFDA","RAERR")
+11 SET TXT(1)="Imaging Location "_RA44NM_" has appointment patterns, and"
+12 SET TXT(2)="cannot be 'pointed to' from a file 79.1 Imaging Location."
+13 SET TXT(3)="Imaging Location "_RA44NM_" has been 're-pointed' to"
+14 SET TXT(4)="Hospital Location "_RA44NM2_"."
+15 SET TXT(5)=" "
DO MES^XPDUTL(.TXT)
+16 QUIT
OK ;this img loc was processed ok
+1 NEW TXT
+2 SET TXT(1)="Imaging Location "_$SELECT($LENGTH(RA44NM2):RA44NM2,1:RA44NM)_" is OK."
+3 SET TXT(2)=" "
DO MES^XPDUTL(.TXT)
+4 QUIT
DEL148 ; Delete 'Telephone/Diagnostic' Stop Code from the Imaging Stop Codes
+1 ; file. Data resides in ^RAMIS(71.5,
+2 NEW %,DA,DIC,DIK,I,RA407,RARRY,RASTOP,TXT,X,Y
SET (I,RASTOP)=0
+3 SET TXT(1)="Deleting the 'Telephone/Diagnostic' Stop Code from the"
+4 SET TXT(2)="Imaging Stop Codes (71.5) file."
SET TXT(3)=" "
+5 FOR
SET I=$ORDER(^RAMIS(71.5,I))
if I'>0
QUIT
Begin DoDot:1
+6 SET RA407(1)=+$PIECE($GET(^RAMIS(71.5,I,0)),"^")
+7 DO GETS^DIQ(40.7,RA407(1)_",",1,"","RARRY")
+8 IF $GET(RARRY(40.7,RA407(1)_",",1))=148
Begin DoDot:2
+9 SET RASTOP=1
SET DA=I
SET DIK="^RAMIS(71.5,"
DO ^DIK
+10 DO BMES^XPDUTL(.TXT)
+11 QUIT
End DoDot:2
QUIT
+12 KILL RARRY
+13 QUIT
End DoDot:1
if RASTOP
QUIT
+14 QUIT
