XUMF390 ;ISS/RAM - Load CLIA & MAMMO ID's;12/15/05
;;8.0;KERNEL;**390**;Jul 10, 1995
;
; $$PARAM^HLCS2 call supported by IA #3552
;
Q
;
MAIN ; -- main
;
D LINK,BG
;
Q
;
BG ; -- background job
;
N ZTRTN,ZTDESC,ZTDTH
;
S ZTRTN="EN^XUMF390"
S ZTDESC="XUMF Load CLIA ID's"
S ZTDTH=$$NOW^XLFDT
S ZTIO=""
;
D ^%ZTLOAD
;
Q
;
EN ; -- entry point
;
D LOAD^XUMF(4)
;
K ^TMP("XUMF ARRAY",$J)
;
N PARAM,XUMFLAG,ERROR,TEST
;
S (ERROR,XUMFLAG,TEST)=0
;
I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
;
L +^TMP("XUMF ARRAY",$J):0 D:'$T
.S ERROR="1^another process is using the Master File Server"
;
I ERROR D EXIT Q
;
D MFS0
;
I ERROR D EXIT Q
;
I '$D(^TMP("XUMF ARRAY",$J)) D
.S ERROR="1^Connection to master file server failed!"
;
I ERROR D EXIT Q
;
D CLIA
;
I ERROR D EXIT Q
;
; -- get MAMMO
;
K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
;
D MFS1
;
I ERROR D EXIT Q
;
I '$D(^TMP("XUMF ARRAY",$J)) D
.S ERROR="1^Connection to master file server failed!"
;
I ERROR D EXIT Q
;
D MAMMO
;
D EXIT
;
Q
;
MFS0 ; -- get CLIA from Institution Master File
;
S PARAM("CDSYS")="CLIA"
S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
;
D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFH
;
Q
;
MFS1 ; -- get ACR# from Institution Master File
;
S PARAM("CDSYS")="MAMMO-ACR"
S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
;
D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFH
;
Q
;
EXIT ; -- cleanup and quit
;
K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J),^TMP("DIERR",$J)
;
L -^TMP("XUMF ARRAY",$J)
;
S ZTREQ="@"
;
Q
;
CLIA ; -- add CLIA ID to Institution file
;
N ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM,OFNME,AGENCY
;
S XUMF=1
;
S ID=""
F S ID=$O(^TMP("XUMF ARRAY",$J,ID)) Q:ID="" D
.S X=^TMP("XUMF ARRAY",$J,ID)
.S STANUM=$P(X,U,3)
.S IEN=$$IEN^XUMF(4,"CLIA",ID)
.I 'IEN,$G(STANUM)'="" S IEN=$O(^DIC(4,"D",STANUM,0))
.Q:'IEN
.S IENS="?+1,"_IEN_","
.K FDA
.S FDA(4.9999,IENS,.01)="CLIA"
.S FDA(4.9999,IENS,.02)=ID
.D UPDATE^DIE("E","FDA")
;
Q
;
MAMMO ; -- add MAMMO ID to Institution file
;
N ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM
;
S XUMF=1
;
S ID=""
F S ID=$O(^TMP("XUMF ARRAY",$J,ID)) Q:ID="" D
.S X=^TMP("XUMF ARRAY",$J,ID)
.S STANUM=$P(X,U,3)
.S IEN=$$IEN^XUMF(4,"MAMMO-ACR",ID)
.I 'IEN,$G(STANUM)'="" S IEN=$O(^DIC(4,"D",STANUM,0))
.Q:'IEN
.S IENS="?+1,"_IEN_","
.K FDA
.S FDA(4.9999,IENS,.01)="MAMMO-ACR"
.S FDA(4.9999,IENS,.02)=ID
.D UPDATE^DIE("E","FDA")
;
Q
;
LINK ;
;
N IEN,FDA,IENS
;
S IEN=$$FIND1^DIC(870,,"BX","XUMF ACK")
S IENS=IEN_","
;
K FDA
S FDA(870,IENS,4.5)=1
D UPDATE^DIE(,"FDA")
;
S IEN=$$FIND1^DIC(870,,"BX","XUMF FORUM")
S IENS=IEN_","
;
K FDA
S FDA(870,IENS,4.5)=1
D UPDATE^DIE(,"FDA")
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF390 3155 printed Apr 09, 2024@21:17:44 Page 2
XUMF390 ;ISS/RAM - Load CLIA & MAMMO ID's;12/15/05
+1 ;;8.0;KERNEL;**390**;Jul 10, 1995
+2 ;
+3 ; $$PARAM^HLCS2 call supported by IA #3552
+4 ;
+5 QUIT
+6 ;
MAIN ; -- main
+1 ;
+2 DO LINK
DO BG
+3 ;
+4 QUIT
+5 ;
BG ; -- background job
+1 ;
+2 NEW ZTRTN,ZTDESC,ZTDTH
+3 ;
+4 SET ZTRTN="EN^XUMF390"
+5 SET ZTDESC="XUMF Load CLIA ID's"
+6 SET ZTDTH=$$NOW^XLFDT
+7 SET ZTIO=""
+8 ;
+9 DO ^%ZTLOAD
+10 ;
+11 QUIT
+12 ;
EN ; -- entry point
+1 ;
+2 DO LOAD^XUMF(4)
+3 ;
+4 KILL ^TMP("XUMF ARRAY",$JOB)
+5 ;
+6 NEW PARAM,XUMFLAG,ERROR,TEST
+7 ;
+8 SET (ERROR,XUMFLAG,TEST)=0
+9 ;
+10 IF $PIECE($$PARAM^HLCS2,U,3)="T"
SET TEST=1
+11 ;
+12 LOCK +^TMP("XUMF ARRAY",$JOB):0
if '$TEST
Begin DoDot:1
+13 SET ERROR="1^another process is using the Master File Server"
End DoDot:1
+14 ;
+15 IF ERROR
DO EXIT
QUIT
+16 ;
+17 DO MFS0
+18 ;
+19 IF ERROR
DO EXIT
QUIT
+20 ;
+21 IF '$DATA(^TMP("XUMF ARRAY",$JOB))
Begin DoDot:1
+22 SET ERROR="1^Connection to master file server failed!"
End DoDot:1
+23 ;
+24 IF ERROR
DO EXIT
QUIT
+25 ;
+26 DO CLIA
+27 ;
+28 IF ERROR
DO EXIT
QUIT
+29 ;
+30 ; -- get MAMMO
+31 ;
+32 KILL ^TMP("XUMF ARRAY",$JOB),^TMP("XUMF MFS",$JOB)
+33 ;
+34 DO MFS1
+35 ;
+36 IF ERROR
DO EXIT
QUIT
+37 ;
+38 IF '$DATA(^TMP("XUMF ARRAY",$JOB))
Begin DoDot:1
+39 SET ERROR="1^Connection to master file server failed!"
End DoDot:1
+40 ;
+41 IF ERROR
DO EXIT
QUIT
+42 ;
+43 DO MAMMO
+44 ;
+45 DO EXIT
+46 ;
+47 QUIT
+48 ;
MFS0 ; -- get CLIA from Institution Master File
+1 ;
+2 SET PARAM("CDSYS")="CLIA"
+3 SET PARAM("LLNK")="XUMF MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")
+4 SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFQ",0))
+5 ;
+6 DO MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+7 DO MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+8 DO MAIN^XUMFH
+9 ;
+10 QUIT
+11 ;
MFS1 ; -- get ACR# from Institution Master File
+1 ;
+2 SET PARAM("CDSYS")="MAMMO-ACR"
+3 SET PARAM("LLNK")="XUMF MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")
+4 SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFQ",0))
+5 ;
+6 DO MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+7 DO MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR)
if ERROR
QUIT
+8 DO MAIN^XUMFH
+9 ;
+10 QUIT
+11 ;
EXIT ; -- cleanup and quit
+1 ;
+2 KILL ^TMP("XUMF ARRAY",$JOB),^TMP("XUMF MFS",$JOB),^TMP("DIERR",$JOB)
+3 ;
+4 LOCK -^TMP("XUMF ARRAY",$JOB)
+5 ;
+6 SET ZTREQ="@"
+7 ;
+8 QUIT
+9 ;
CLIA ; -- add CLIA ID to Institution file
+1 ;
+2 NEW ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM,OFNME,AGENCY
+3 ;
+4 SET XUMF=1
+5 ;
+6 SET ID=""
+7 FOR
SET ID=$ORDER(^TMP("XUMF ARRAY",$JOB,ID))
if ID=""
QUIT
Begin DoDot:1
+8 SET X=^TMP("XUMF ARRAY",$JOB,ID)
+9 SET STANUM=$PIECE(X,U,3)
+10 SET IEN=$$IEN^XUMF(4,"CLIA",ID)
+11 IF 'IEN
IF $GET(STANUM)'=""
SET IEN=$ORDER(^DIC(4,"D",STANUM,0))
+12 if 'IEN
QUIT
+13 SET IENS="?+1,"_IEN_","
+14 KILL FDA
+15 SET FDA(4.9999,IENS,.01)="CLIA"
+16 SET FDA(4.9999,IENS,.02)=ID
+17 DO UPDATE^DIE("E","FDA")
End DoDot:1
+18 ;
+19 QUIT
+20 ;
MAMMO ; -- add MAMMO ID to Institution file
+1 ;
+2 NEW ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM
+3 ;
+4 SET XUMF=1
+5 ;
+6 SET ID=""
+7 FOR
SET ID=$ORDER(^TMP("XUMF ARRAY",$JOB,ID))
if ID=""
QUIT
Begin DoDot:1
+8 SET X=^TMP("XUMF ARRAY",$JOB,ID)
+9 SET STANUM=$PIECE(X,U,3)
+10 SET IEN=$$IEN^XUMF(4,"MAMMO-ACR",ID)
+11 IF 'IEN
IF $GET(STANUM)'=""
SET IEN=$ORDER(^DIC(4,"D",STANUM,0))
+12 if 'IEN
QUIT
+13 SET IENS="?+1,"_IEN_","
+14 KILL FDA
+15 SET FDA(4.9999,IENS,.01)="MAMMO-ACR"
+16 SET FDA(4.9999,IENS,.02)=ID
+17 DO UPDATE^DIE("E","FDA")
End DoDot:1
+18 ;
+19 QUIT
+20 ;
LINK ;
+1 ;
+2 NEW IEN,FDA,IENS
+3 ;
+4 SET IEN=$$FIND1^DIC(870,,"BX","XUMF ACK")
+5 SET IENS=IEN_","
+6 ;
+7 KILL FDA
+8 SET FDA(870,IENS,4.5)=1
+9 DO UPDATE^DIE(,"FDA")
+10 ;
+11 SET IEN=$$FIND1^DIC(870,,"BX","XUMF FORUM")
+12 SET IENS=IEN_","
+13 ;
+14 KILL FDA
+15 SET FDA(870,IENS,4.5)=1
+16 DO UPDATE^DIE(,"FDA")
+17 ;
+18 QUIT
+19 ;
