RASYS1 ;HISC/CAH - Utility to update I-Loc Type to Clinic ;10/30/96 10:00
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1(RA791) ;For each imaging loc, get file 44 pointer, DSS ID, Div
;and give to MAS to set/reset params on the file 44 entry
; Input: -> ien of entry in the 'Imaging Locations' file (79.1)
N RA44,RA44NM,RA44NM2,RADSS,RADSSNM,RADIV,RAERRCNT,RA44NEW,RATRY
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 Q:RAXIT
S RA44NM=$P($G(^SC(+RA44,0)),"^",1)
S RADSS=$P(RA791(0),"^",22) I 'RADSS D ERRDSS Q:RAXIT
S RADSSNM=$P($G(^DIC(40.7,+RADSS,0)),"^",2)
S RADIV=$G(^RA(79.1,+RA791,"DIV")) I 'RADIV D ERRDIV Q:RAXIT
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
ERR44 ;bad file 44 pointer
S RAERRCNT=RAERRCNT+1
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Imaging Location file #79.1 internal entry #"_RA44
W !,"is a broken pointer to Hospital Location file #44."
W !,"IRM must resolve this problem, then the Rad/Nuc Med ADPAC"
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"should use the Location Parameter Set-up [RA SYSLOC] option"
W !,"to edit this Imaging Location, and the Division Parameter"
W !,"Set-up [RA SYSDIV] option to assign it to a division.",!," "
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
Q
ERRDSS ;bad file 40.7 pointer (DSS ID/Stop Code)
S RAERRCNT=RAERRCNT+1
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Imaging Location file #79.1 entry "_$S($L(RA44NM):RA44NM,1:RA44)_" has a missing"
W !,"or invalid DSS ID. The Radiology/Nuclear Medicine ADPAC should"
W !,"use the Location Parameter Set-up [RA SYSLOC] option to enter"
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"a valid imaging DSS Code for this imaging location.",!," "
Q
ERRDIV ;bad or non-existent Division on active imaging loc
S RAERRCNT=RAERRCNT+1
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Imaging Location file #79.1 entry "_$S($L(RA44NM):RA44NM,1:RA44)_" is not assigned"
W !,"to a Rad/Nuc Med Division. If Imaging exams are to be registered"
W !,"in this imaging location, or if there are incomplete exams"
W !,"already registered to this location, the Radiology/Nuclear"
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Med ADPAC should use the Division Parameter Set-up [RA SYSDIV]"
W !,"option to assign this imaging location to the appropriate"
W !,"Rad/Nuc Med Division.",!," "
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
Q
ERRMSG(RAX) ; Explain why the $$RAD call failed.
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Scheduling routine could not reset Hospital Location"
W !,"file #44 params for Imaging Location "_$S($L(RA44NM2):RA44NM2,1:RA44NM)
W !,"to agree with params on the Imaging Location file #79.1."
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"IRM should investigate the cause of this Scheduling error message:"
W !," * "_$P(RAX,"^",3)_" * ",!," "
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 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")
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Imaging Location "_RA44NM_" has appointment patterns, and"
W !,"cannot be 'pointed to' from a file 79.1 Imaging Location."
W !,"Imaging Location "_RA44NM_" has been 're-pointed' to"
I $Y>(IOSL-6) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Hospital Location "_RA44NM2_".",!," "
Q
OK ;this img loc was processed ok
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
W !,"Imaging Location "_$S($L(RA44NM2):RA44NM2,1:RA44NM)_" is OK.",!," "
Q
RASYS1 ;HISC/CAH - Utility to update I-Loc Type to Clinic ;10/30/96 10:00
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1(RA791) ;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 ; Input: -> ien of entry in the 'Imaging Locations' file (79.1)
+3 NEW RA44,RA44NM,RA44NM2,RADSS,RADSSNM,RADIV,RAERRCNT,RA44NEW,RATRY
+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
IF RAXIT
QUIT
+7 SET RA44NM=$PIECE($GET(^SC(+RA44,0)),"^",1)
+8 SET RADSS=$PIECE(RA791(0),"^",22)
IF 'RADSS
DO ERRDSS
IF RAXIT
QUIT
+9 SET RADSSNM=$PIECE($GET(^DIC(40.7,+RADSS,0)),"^",2)
+10 SET RADIV=$GET(^RA(79.1,+RA791,"DIV"))
IF 'RADIV
DO ERRDIV
IF RAXIT
QUIT
+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
ERR44 ;bad file 44 pointer
+1 SET RAERRCNT=RAERRCNT+1
+2 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+3 WRITE !,"Imaging Location file #79.1 internal entry #"_RA44
+4 WRITE !,"is a broken pointer to Hospital Location file #44."
+5 WRITE !,"IRM must resolve this problem, then the Rad/Nuc Med ADPAC"
+6 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+7 WRITE !,"should use the Location Parameter Set-up [RA SYSLOC] option"
+8 WRITE !,"to edit this Imaging Location, and the Division Parameter"
+9 WRITE !,"Set-up [RA SYSDIV] option to assign it to a division.",!," "
+10 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+11 QUIT
ERRDSS ;bad file 40.7 pointer (DSS ID/Stop Code)
+1 SET RAERRCNT=RAERRCNT+1
+2 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+3 WRITE !,"Imaging Location file #79.1 entry "_$SELECT($LENGTH(RA44NM):RA44NM,1:RA44)_" has a missing"
+4 WRITE !,"or invalid DSS ID. The Radiology/Nuclear Medicine ADPAC should"
+5 WRITE !,"use the Location Parameter Set-up [RA SYSLOC] option to enter"
+6 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+7 WRITE !,"a valid imaging DSS Code for this imaging location.",!," "
+8 QUIT
ERRDIV ;bad or non-existent Division on active imaging loc
+1 SET RAERRCNT=RAERRCNT+1
+2 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+3 WRITE !,"Imaging Location file #79.1 entry "_$SELECT($LENGTH(RA44NM):RA44NM,1:RA44)_" is not assigned"
+4 WRITE !,"to a Rad/Nuc Med Division. If Imaging exams are to be registered"
+5 WRITE !,"in this imaging location, or if there are incomplete exams"
+6 WRITE !,"already registered to this location, the Radiology/Nuclear"
+7 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+8 WRITE !,"Med ADPAC should use the Division Parameter Set-up [RA SYSDIV]"
+9 WRITE !,"option to assign this imaging location to the appropriate"
+10 WRITE !,"Rad/Nuc Med Division.",!," "
+11 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+12 QUIT
ERRMSG(RAX) ; Explain why the $$RAD call failed.
+1 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+2 WRITE !,"Scheduling routine could not reset Hospital Location"
+3 WRITE !,"file #44 params for Imaging Location "_$SELECT($LENGTH(RA44NM2):RA44NM2,1:RA44NM)
+4 WRITE !,"to agree with params on the Imaging Location file #79.1."
+5 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+6 WRITE !,"IRM should investigate the cause of this Scheduling error message:"
+7 WRITE !," * "_$PIECE(RAX,"^",3)_" * ",!," "
+8 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 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 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+12 WRITE !,"Imaging Location "_RA44NM_" has appointment patterns, and"
+13 WRITE !,"cannot be 'pointed to' from a file 79.1 Imaging Location."
+14 WRITE !,"Imaging Location "_RA44NM_" has been 're-pointed' to"
+15 IF $Y>(IOSL-6)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+16 WRITE !,"Hospital Location "_RA44NM2_".",!," "
+17 QUIT
OK ;this img loc was processed ok
+1 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+2 WRITE !,"Imaging Location "_$SELECT($LENGTH(RA44NM2):RA44NM2,1:RA44NM)_" is OK.",!," "
+3 QUIT
