XUMFEIMF ;OIFO-OAK/RAM - Edit IMF ;06/28/00
;;8.0;KERNEL;**217,335**;Jul 10, 1995
;
; $$PARAM^HLCS2 call supported by IA #3552
;
Q
;
MAIN ; -- main
;
D INIT,SEL1
;
I $G(DIRUT) G EXIT
I ERROR H 5 D EXIT G MAIN
;
EDT ;
D PRE,EDIT,POST
;
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Are you ready to update the Institution Master File"
D ^DIR K DIR
I $G(DIRUT) D G EDT
.W !!,"WARNING: You modified your entry without updating the IMF!"
G:'Y EDT
;
SEND ;
W !,"...send HL7 message to Master File Server..."
S PARAM("LLNK")="XUMF IMF MFK^XUMF "_$S('TEST:"FORUM",1:"TEST")
S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF IMF MFN",0))
D MAIN^XUMFP(4,IEN,0,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFI(4,IEN,0,.PARAM,.ERROR)
;
I $G(ERROR) W !,$G(ERROR),!
I '$G(ERROR) W !,"Sent."
;
H 1
;
L -^DIC(4,IEN)
;
D EXIT G MAIN
;
Q
;
INIT ; -- initialize
;
K ^TMP("XUMF MFS",$J),^TMP("HLS",$J),^TMP("HLA",$J),PARAM
D CLEAN^DILF
;
;
S (ERROR,TEST,FLAG)=0
;
I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
;
;
S XUMF=1
;
D LOAD^XUMF(4.1)
;
Q
;
SEL1 ; -- select one institution
;
D CHK^XUMF333
;
W !
;
K DIR
S DIR(0)="F^3:7^K:'(X?3N.AN) X"
S DIR("A")="Enter Station Number"
D ^DIR Q:$G(DIRUT)
;
S STA=Y
;
S IEN=$O(^DIC(4,"D",STA,0))
;
I 'IEN W " Invalid selection!" H 2 G SEL1
;
L +^DIC(4,IEN):0 I '$T D Q
.S ERROR="1^Another user is editing this entry."
.W !,ERROR,!
;
I 'IEN D Q
.S ERROR="1^Not an existing Station Number,"
.W !,ERROR,!
;
I $E($$STA^XUAF4(+$G(DUZ(2))),1,3)'=$E(STA,1,3) D Q
.S ERROR="1^Option may only be used to edit your facility!"
.W !,ERROR
.W !," to edit an inactive faciliy log on to that division"
.W !," you must have DIVISION in your NEW PERSON multiple."
.W !!," If Inactive facility not selectable - assign with"
.W !," XUMGR security key."
;
Q
;
PRE ; -- pre-udpate
;
S N0=$G(^DIC(4,+IEN,0))
S N1=$G(^DIC(4,+IEN,1))
S N3=$G(^DIC(4,+IEN,3))
S N4=$G(^DIC(4,+IEN,4))
S NV=$G(^DIC(4,+IEN,7,1))
S NP=$G(^DIC(4,+IEN,7,2))
S N99=$G(^DIC(4,+IEN,99))
;
Q
;
EDIT ; -- address edit
;
S DIE("NO^")="BACK"
;
; edit template
S DIE=4,DA=IEN
S DR="[XUMF IMF EDIT]"
D ^DIE
;
; if inactive remove parent and visn then quit
I $P($G(^DIC(4,+IEN,99)),U,4) D Q
.K IENS,FDA
.S IENS="1,"_IEN_","
.S FDA(4.014,IENS,.01)="@"
.D FILE^DIE("E","FDA")
.K IENS,FDA
.S IENS="2,"_IEN_","
.S FDA(4.014,IENS,.01)="@"
.D FILE^DIE("E","FDA")
.W !
;
VN K DIR
S DIR(0)="N^1:23^"
S DIR("A")="Enter VISN Number"
D ^DIR
;
G:'Y VN
;
K IENS,FDA
S IENS="?+1,"_IEN_","
S FDA(4.014,IENS,.01)="VISN"
S FDA(4.014,IENS,1)="VISN "_Y
D UPDATE^DIE("E","FDA")
;
PF ;
; parent facility
W !,"Parent ASSOCIATION - Enter the admin PARENT for this facility"
S DIE="^DIC(4,"_IEN_",7,"
S DA(1)=IEN,DA=2
S DR="1~PARENT"
D ^DIE
W !
;
Q
;
POST ; -- post update
;
I $P($G(^DIC(4,+IEN,0)),U,2)'=$P($G(N0),U,2) S FLAG=1 Q
I $G(^DIC(4,+IEN,1))'=$G(N1) S FLAG=1 Q
I $G(^DIC(4,+IEN,4))'=$G(N4) S FLAG=1 Q
I $G(^DIC(4,+IEN,3))'=$G(N3) S FLAG=1 Q
I $G(^DIC(4,+IEN,7,1))'=$G(NV) S FLAG=1 Q
I $G(^DIC(4,+IEN,7,2))'=$G(NP) S FLAG=1 Q
I $G(^DIC(4,+IEN,99))'=$G(N99) S FLAG=1 Q
;
Q
;
EXIT ; -- clean up
;
D CLEAN^DILF,KILL^XUSCLEAN
K ^TMP("HLS",$J),^TMP("HLA",$J),^TMP("XUMF MFS",$J)
;
K N0,N1,N3,N4,NV,NP,N99,XUMF,DIRUT,PARAM,DA,DR,DIE
K DIC,DIR,X,Y,NAME,STA,FLAG,IEN,TEST,ERROR,IENS
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFEIMF 3534 printed Apr 09, 2024@21:16:55 Page 2
XUMFEIMF ;OIFO-OAK/RAM - Edit IMF ;06/28/00
+1 ;;8.0;KERNEL;**217,335**;Jul 10, 1995
+2 ;
+3 ; $$PARAM^HLCS2 call supported by IA #3552
+4 ;
+5 QUIT
+6 ;
MAIN ; -- main
+1 ;
+2 DO INIT
DO SEL1
+3 ;
+4 IF $GET(DIRUT)
GOTO EXIT
+5 IF ERROR
HANG 5
DO EXIT
GOTO MAIN
+6 ;
EDT ;
+1 DO PRE
DO EDIT
DO POST
+2 ;
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
+4 SET DIR("A")="Are you ready to update the Institution Master File"
+5 DO ^DIR
KILL DIR
+6 IF $GET(DIRUT)
Begin DoDot:1
+7 WRITE !!,"WARNING: You modified your entry without updating the IMF!"
End DoDot:1
GOTO EDT
+8 if 'Y
GOTO EDT
+9 ;
SEND ;
+1 WRITE !,"...send HL7 message to Master File Server..."
+2 SET PARAM("LLNK")="XUMF IMF MFK^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")
+3 SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF IMF MFN",0))
+4 DO MAIN^XUMFP(4,IEN,0,.PARAM,.ERROR)
if ERROR
QUIT
+5 DO MAIN^XUMFI(4,IEN,0,.PARAM,.ERROR)
+6 ;
+7 IF $GET(ERROR)
WRITE !,$GET(ERROR),!
+8 IF '$GET(ERROR)
WRITE !,"Sent."
+9 ;
+10 HANG 1
+11 ;
+12 LOCK -^DIC(4,IEN)
+13 ;
+14 DO EXIT
GOTO MAIN
+15 ;
+16 QUIT
+17 ;
INIT ; -- initialize
+1 ;
+2 KILL ^TMP("XUMF MFS",$JOB),^TMP("HLS",$JOB),^TMP("HLA",$JOB),PARAM
+3 DO CLEAN^DILF
+4 ;
+5 ;
+6 SET (ERROR,TEST,FLAG)=0
+7 ;
+8 IF $PIECE($$PARAM^HLCS2,U,3)="T"
SET TEST=1
+9 ;
+10 ;
+11 SET XUMF=1
+12 ;
+13 DO LOAD^XUMF(4.1)
+14 ;
+15 QUIT
+16 ;
SEL1 ; -- select one institution
+1 ;
+2 DO CHK^XUMF333
+3 ;
+4 WRITE !
+5 ;
+6 KILL DIR
+7 SET DIR(0)="F^3:7^K:'(X?3N.AN) X"
+8 SET DIR("A")="Enter Station Number"
+9 DO ^DIR
if $GET(DIRUT)
QUIT
+10 ;
+11 SET STA=Y
+12 ;
+13 SET IEN=$ORDER(^DIC(4,"D",STA,0))
+14 ;
+15 IF 'IEN
WRITE " Invalid selection!"
HANG 2
GOTO SEL1
+16 ;
+17 LOCK +^DIC(4,IEN):0
IF '$TEST
Begin DoDot:1
+18 SET ERROR="1^Another user is editing this entry."
+19 WRITE !,ERROR,!
End DoDot:1
QUIT
+20 ;
+21 IF 'IEN
Begin DoDot:1
+22 SET ERROR="1^Not an existing Station Number,"
+23 WRITE !,ERROR,!
End DoDot:1
QUIT
+24 ;
+25 IF $EXTRACT($$STA^XUAF4(+$GET(DUZ(2))),1,3)'=$EXTRACT(STA,1,3)
Begin DoDot:1
+26 SET ERROR="1^Option may only be used to edit your facility!"
+27 WRITE !,ERROR
+28 WRITE !," to edit an inactive faciliy log on to that division"
+29 WRITE !," you must have DIVISION in your NEW PERSON multiple."
+30 WRITE !!," If Inactive facility not selectable - assign with"
+31 WRITE !," XUMGR security key."
End DoDot:1
QUIT
+32 ;
+33 QUIT
+34 ;
PRE ; -- pre-udpate
+1 ;
+2 SET N0=$GET(^DIC(4,+IEN,0))
+3 SET N1=$GET(^DIC(4,+IEN,1))
+4 SET N3=$GET(^DIC(4,+IEN,3))
+5 SET N4=$GET(^DIC(4,+IEN,4))
+6 SET NV=$GET(^DIC(4,+IEN,7,1))
+7 SET NP=$GET(^DIC(4,+IEN,7,2))
+8 SET N99=$GET(^DIC(4,+IEN,99))
+9 ;
+10 QUIT
+11 ;
EDIT ; -- address edit
+1 ;
+2 SET DIE("NO^")="BACK"
+3 ;
+4 ; edit template
+5 SET DIE=4
SET DA=IEN
+6 SET DR="[XUMF IMF EDIT]"
+7 DO ^DIE
+8 ;
+9 ; if inactive remove parent and visn then quit
+10 IF $PIECE($GET(^DIC(4,+IEN,99)),U,4)
Begin DoDot:1
+11 KILL IENS,FDA
+12 SET IENS="1,"_IEN_","
+13 SET FDA(4.014,IENS,.01)="@"
+14 DO FILE^DIE("E","FDA")
+15 KILL IENS,FDA
+16 SET IENS="2,"_IEN_","
+17 SET FDA(4.014,IENS,.01)="@"
+18 DO FILE^DIE("E","FDA")
+19 WRITE !
End DoDot:1
QUIT
+20 ;
VN KILL DIR
+1 SET DIR(0)="N^1:23^"
+2 SET DIR("A")="Enter VISN Number"
+3 DO ^DIR
+4 ;
+5 if 'Y
GOTO VN
+6 ;
+7 KILL IENS,FDA
+8 SET IENS="?+1,"_IEN_","
+9 SET FDA(4.014,IENS,.01)="VISN"
+10 SET FDA(4.014,IENS,1)="VISN "_Y
+11 DO UPDATE^DIE("E","FDA")
+12 ;
PF ;
+1 ; parent facility
+2 WRITE !,"Parent ASSOCIATION - Enter the admin PARENT for this facility"
+3 SET DIE="^DIC(4,"_IEN_",7,"
+4 SET DA(1)=IEN
SET DA=2
+5 SET DR="1~PARENT"
+6 DO ^DIE
+7 WRITE !
+8 ;
+9 QUIT
+10 ;
POST ; -- post update
+1 ;
+2 IF $PIECE($GET(^DIC(4,+IEN,0)),U,2)'=$PIECE($GET(N0),U,2)
SET FLAG=1
QUIT
+3 IF $GET(^DIC(4,+IEN,1))'=$GET(N1)
SET FLAG=1
QUIT
+4 IF $GET(^DIC(4,+IEN,4))'=$GET(N4)
SET FLAG=1
QUIT
+5 IF $GET(^DIC(4,+IEN,3))'=$GET(N3)
SET FLAG=1
QUIT
+6 IF $GET(^DIC(4,+IEN,7,1))'=$GET(NV)
SET FLAG=1
QUIT
+7 IF $GET(^DIC(4,+IEN,7,2))'=$GET(NP)
SET FLAG=1
QUIT
+8 IF $GET(^DIC(4,+IEN,99))'=$GET(N99)
SET FLAG=1
QUIT
+9 ;
+10 QUIT
+11 ;
EXIT ; -- clean up
+1 ;
+2 DO CLEAN^DILF
DO KILL^XUSCLEAN
+3 KILL ^TMP("HLS",$JOB),^TMP("HLA",$JOB),^TMP("XUMF MFS",$JOB)
+4 ;
+5 KILL N0,N1,N3,N4,NV,NP,N99,XUMF,DIRUT,PARAM,DA,DR,DIE
+6 KILL DIC,DIR,X,Y,NAME,STA,FLAG,IEN,TEST,ERROR,IENS
+7 ;
+8 QUIT
+9 ;
