- TIUMAP ; ISL/JER - TIU/VHA Enterprise Document Type Ontology Mapper ; 04/18/07
- ;;1.0;TEXT INTEGRATION UTILITIES;**211,225**;Jun 20, 1997;Build 13
- MAIN ; Main subroutine
- N TIUOK,TIUMODE,TIULUSE,TIUHOUR,TIUNOW,TIUZR,TIUTOD,TIUBACK,TIUACT,TIUMAPT
- N SALUT,GREET,PROGRESS,DIRUT,DUOUT,DTOUT,TIUOUT S TIUOUT=0
- S ^XTMP("TIUMAP",0)=$$FMADD^XLFDT(DT,730)_U_DT,TIUNOW=$$NOW^XLFDT
- S TIUHOUR=$E($P(TIUNOW,".",2),1,2)
- S TIUTOD=$S(TIUHOUR'<17:"EVENING",TIUHOUR'<12:"AFTERNOON",1:"MORNING")
- S TIUZR=$$NAME^TIULS($$PERSNAME^TIULC1(DUZ),"FIRST")
- S TIULUSE=+$G(^XTMP("TIUMAP","USER",DUZ))
- S TIUMAPT=+$$MAPTCNT,TIUACT=+$$ACTCNT
- S PROGRESS(0)="So far, "_TIUMAPT_" of "_TIUACT_" Active Titles have been mapped!"
- S PROGRESS(1)=$$PROGRESS(TIUMAPT,TIUACT)
- S SALUT="Good "_TIUTOD_" "_TIUZR_"!"
- S GREET=$S(+TIULUSE:"And WELCOME BACK for ANOTHER ride on the MTA!!!",1:"And WELCOME to your FIRST RIDE on the MTA!!!")
- W @IOF,!!?9,"****************************************************************"
- W !?9,"*",$$PAD(SALUT,"L"),SALUT,$$PAD(SALUT,"R"),"*"
- W !?9,"*",$$PAD(GREET,"L"),GREET,$$PAD(GREET,"R"),"*"
- I '+TIULUSE D
- . W !?9,"* *"
- . W !?9,"* This option will help you map your LOCAL TIU Titles to the *"
- . W !?9,"* VHA Enterprise Document Type Ontology which VA is helping to *"
- . W !?9,"* Develop as an International Normative Standard supporting *"
- . W !?9,"* interchange of Clinical Documents. *"
- I +TIUMAPT>0 D
- . W !?9,"* *"
- . W !?9,"*",$$PAD(PROGRESS(0),"L"),PROGRESS(0),$$PAD(PROGRESS(0),"R"),"*"
- . W !?9,"*",$$PAD(PROGRESS(1),"L"),PROGRESS(1),$$PAD(PROGRESS(1),"R"),"*"
- W !?9,"* *"
- W !?9,"* In preparation for migration to the HDR, ALL LOCAL titles *"
- W !?9,"* MUST be mapped to Standard Titles BEFORE transmittal of TIU *"
- W !?9,"* Documents to the HDR can begin. *"
- W !?9,"* *"
- W !?9,"* You may quit mapping titles at any time, and continue your *"
- W !?9,"* work from the last successfully mapped title. The only *"
- W !?9,"* catch is that any ACTIVE LOCAL Titles that are not mapped *"
- W !?9,"* when transmission to the HDR is initiated will be *"
- W !?9,"* INACTIVATED, so please finish this process expeditiously... *"
- W !?9,"****************************************************************",!
- S TIUOK=$$READ^TIUU("Y"," ... Are you READY to map","NO") Q:$D(DIRUT)
- I +TIUOK'>0 W !!?9,$C(7),"... Very well, no damage done!" Q
- S ^XTMP("TIUMAP","USER",DUZ)=TIUNOW
- D LOOP
- Q
- PROGRESS(MAPPED,ACTIVE) ; Figure out progress
- N TIUI,TIUY,BR,BRSIZE S TIUY="You're at Kendall Square Station..."
- S BRSIZE=ACTIVE/17,BR=MAPPED\BRSIZE+1
- S TIUY=$P($T(STOPS+BR),";",3)
- Q TIUY
- STOPS ; Get the stops
- ;;You're at Kendall Square Station...Hand in your dime!
- ;;You're at Charles Circle/MGH...
- ;;You're at Park Street Station, changing for Jamaica Plain...
- ;;You're at Boyleston Street Station...
- ;;You're at Arlington Station...
- ;;You're at Copley Station...
- ;;You're at Prudential Station...
- ;;You're at Symphony Station...
- ;;You're at Northeastern University Station...
- ;;You're at Museum of Fine Arts Station...
- ;;You're at Longwood Medical Area Station...
- ;;You're at Brigham Circle Station...
- ;;You're at Fenwood Street Station...
- ;;You're at Mission Park Station...
- ;;You're at Riverway Station...
- ;;You're at Back of the Hill Station...
- ;;You're at Heath Street Station..."One more nickel."
- ;;Wuzzat? NO NICKEL?! Then you'll NEVER return! Ah-HA-Ha-ha!!!
- Q
- PAD(MESSAGE,SIDE) ; Compute pad for message
- N LEN,PAD
- S LEN=(64-$L(MESSAGE))\2
- I $L(MESSAGE)#2,SIDE="R" S LEN=LEN+1
- S $P(PAD," ",LEN)=""
- Q PAD
- LOOP ; Loop sequentially through titles
- N TIUDA,TIUOUT W @IOF
- S TIUDA=+$G(^XTMP("TIUMAP","CHKPNT"))
- F S TIUDA=$O(^TIU(8925.1,"AT","DOC",TIUDA)) Q:TIUDA'>0 D Q:+$G(DIROUT)!+$G(TIUOUT)
- . N TIUD0,TIUNM,TIUTYP,DIRUT
- . Q:+$G(^TIU(8925.1,TIUDA,15)) ; If already mapped, continue to next
- . S TIUD0=$G(^TIU(8925.1,TIUDA,0)),TIUTYP=$P(TIUD0,U,4)
- . ; Don't process non-title type document definitions
- . Q:TIUTYP'="DOC"
- . Q:+$P(TIUD0,U,7)'=11 ; Only require mapping of ACTIVE local titles
- . S TIUNM=$$STRIP^TIUMAP2($P(TIUD0,U))
- . L +^TIU(8925.1,TIUDA,15):1
- . E Q ; If lock request fails, continue to next title
- . W !,"For the LOCAL Title: ",TIUNM,!
- . D MAP(TIUDA,TIUNM)
- . L -^TIU(8925.1,TIUDA,15):1 ; Decrement lock
- . Q:+$G(TIUOUT)
- . I +$G(DIRUT) D Q
- . . N DIRUT
- . . W:$$READ^TIUU("E") "" S:+$G(DIRUT) TIUOUT=1
- . S ^XTMP("TIUMAP","CHKPNT")=TIUDA
- . S ^XTMP("TIUMAP","MAPCNT")=+$G(^XTMP("TIUMAP","MAPCNT"))+1
- Q
- SINGLES ; Map specific INDIVIDUAL titles
- N TIUDA,TIUOUT W @IOF
- F S TIUDA=+$$LTTL D Q:TIUDA'>0!+$G(DIROUT)!+$G(TIUOUT)
- . N TIUD0,TIUNM,TIUTYP,DIRUT
- . S TIUD0=$G(^TIU(8925.1,TIUDA,0)),TIUTYP=$P(TIUD0,U,4)
- . ; Don't process non-title type document definitions
- . Q:TIUTYP'="DOC"
- . S TIUNM=$$STRIP^TIUMAP2($P(TIUD0,U))
- . Q:'$$PAGE^TIUMAP2(TIUNM) W !!,"For the LOCAL Title: ",TIUNM,!
- . D MAP(TIUDA,TIUNM) Q:+$G(DIRUT)
- Q
- LTTL() ; Call DIC to look-up title
- N TIUDA,TIUNM,DIC,X,Y,DTOUT,DUOUT
- S DIC=8925.1,DIC(0)="AEMQ",DIC("A")="Select TITLE: "
- S DIC("S")="I $P(^(0),U,4)=""DOC"",($P(^(0),U,7)=11)"
- D ^DIC K DIC("S") I $D(DTOUT)!$D(DUOUT) S DIRUT=1 S:X="^^" DIROUT=1
- Q Y
- ACTCNT() ; Get count of active titles
- N TIUI,TIUY,TIUT S (TIUI,TIUT,TIUY)=0
- F S TIUI=$O(^TIU(8925.1,"AT","DOC",TIUI)) Q:+TIUI'>0 S TIUT=TIUT+1 I $$ACTIVE(TIUI) S TIUY=TIUY+1
- Q TIUY_U_TIUT
- MAPTCNT() ; Get count of mapped titles
- N TIUI,TIUY S (TIUI,TIUY)=0
- F S TIUI=$O(^TIU(8925.1,"ALOINC",TIUI)) Q:+TIUI'>0 D
- . N TIUJ S TIUJ=0
- . F S TIUJ=$O(^TIU(8925.1,"ALOINC",TIUI,TIUJ)) Q:+TIUJ'>0 I $$ACTIVE(TIUJ) S TIUY=TIUY+1
- I (+$G(^XTMP("TIUMAP","MAPCNT"))>0),(^("MAPCNT")'=TIUY) S ^("MAPCNT")=TIUY
- Q TIUY
- ACTIVE(TIUDA) ; Is a given title active?
- Q $P($G(^TIU(8925.1,TIUDA,0)),U,7)=11
- MAP(TIUDA,TIUNM) ; Map each LOCAL Title
- N RESULT S RESULT=0
- Q:'$$PAGE^TIUMAP2(TIUNM) W !,"Attempting to map ",TIUNM,!?2,"to a VHA Enterprise Standard Title...",!
- ; Bid for LOCK
- L +^TIU(8925.1,TIUDA,15):1
- E D Q
- . W !,$C(7),"Another user is mapping this title...",!
- . W:$$READ^TIUU("E") "" S:+$G(DIRUT) TIUOUT=1
- ; First, check whether the LOCAL Title is already mapped
- I +$G(^TIU(8925.1,+TIUDA,15)) D Q:RESULT<0!+$G(DIRUT)
- . N TIUY S TIUY=0
- . W !?5,"The LOCAL Title: ",TIUNM,!?7,"is already mapped to",!,"VHA Enterprise Title: ",$$LOINCNM(+$G(^TIU(8925.1,+TIUDA,15))),!
- . S TIUY=$$READ^TIUU("YA","Do you want to RE-MAP it? ","NO")
- . I +TIUY'>0 W $C(7),!,"... OK, No Harm Done!",! S RESULT=-1
- . E W !
- ; Next, check for an exact match
- S RESULT=+$O(^TIU(8926.1,"B",TIUNM,RESULT))
- I RESULT D Q:+RESULT'>0!+$G(DIRUT) I 1
- . Q:'$$PAGE^TIUMAP2(TIUNM) W !,"Found Exact Match with VHA Enterprise Standard Title: ",TIUNM,"."
- . I $$SCREEN^XTID(8926.1,"",+RESULT_",") D Q:'+RESULT
- . . N TIUACT
- . . W !,"The corresponding VHA Enterprise Standard Title is INACTIVE."
- . . W !,"You'll need to map ",TIUNM," manually to a different title,",!," or inactivate the local title.",!
- . . S RESULT=0
- . . S TIUACT=$$READ^TIUU("SA^M:map;I:inactivate","Select action: ","map") I +$G(DIRUT) S TIUOUT=1 Q
- . . I $P(TIUACT,U)="I" D INACT^TIUMAP2(TIUDA) Q
- . . I $P(TIUACT,U)="M" W !!,"Attempting to map ",TIUNM," to a different title...",! D PARSE^TIUMAP1(.RESULT,TIUNM)
- . S RESULT(1)=RESULT_U_$P($G(^TIU(8926.1,+RESULT,0)),U)_U_TIUNM
- . D CONFIRM^TIUMAP1(.RESULT,"Yes")
- . I +RESULT'>0!+$G(DIRUT) D LOG^TIUMAP1(TIUNM,TIUDA)
- ; Otherwise, parse the title, attempting to map each word
- E D Q:+RESULT'>0!+$G(DIRUT)!+$G(TIUOUT)
- . D PARSE^TIUMAP1(.RESULT,TIUNM)
- . I RESULT>0,'+$G(DIRUT) D CONFIRM^TIUMAP1(.RESULT,"Yes")
- . I +RESULT'>0!+$G(DIRUT) D LOG^TIUMAP1(TIUNM,TIUDA)
- D POINT(TIUDA,.RESULT)
- Q
- LOINCNM(TIULDA) ; Resolve name of VHA Enterprise Title
- Q $P($G(^TIU(8926.1,+TIULDA,0)),U)
- POINT(DA,RESULT) ; Point the LOCAL Title entry in file #8925.1 at the VHA Enterprise Title
- N DIE,DR S DIE="^TIU(8925.1,",DR="1501////^S X="_+RESULT_";1502////^S X="_$$NOW^XLFDT_";1503////^S X="_DUZ
- D ^DIE W !?13,"Done.",!
- ; Drop LOCK
- L -^TIU(8925.1,DA,15):1
- I $P($G(RESULT(1)),U,3)]"" K ^XTMP("TIUMAP","FAIL",$P($G(RESULT(1)),U,3),DA)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUMAP 8583 printed Feb 19, 2025@00:08:59 Page 2
- TIUMAP ; ISL/JER - TIU/VHA Enterprise Document Type Ontology Mapper ; 04/18/07
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**211,225**;Jun 20, 1997;Build 13
- MAIN ; Main subroutine
- +1 NEW TIUOK,TIUMODE,TIULUSE,TIUHOUR,TIUNOW,TIUZR,TIUTOD,TIUBACK,TIUACT,TIUMAPT
- +2 NEW SALUT,GREET,PROGRESS,DIRUT,DUOUT,DTOUT,TIUOUT
- SET TIUOUT=0
- +3 SET ^XTMP("TIUMAP",0)=$$FMADD^XLFDT(DT,730)_U_DT
- SET TIUNOW=$$NOW^XLFDT
- +4 SET TIUHOUR=$EXTRACT($PIECE(TIUNOW,".",2),1,2)
- +5 SET TIUTOD=$SELECT(TIUHOUR'<17:"EVENING",TIUHOUR'<12:"AFTERNOON",1:"MORNING")
- +6 SET TIUZR=$$NAME^TIULS($$PERSNAME^TIULC1(DUZ),"FIRST")
- +7 SET TIULUSE=+$GET(^XTMP("TIUMAP","USER",DUZ))
- +8 SET TIUMAPT=+$$MAPTCNT
- SET TIUACT=+$$ACTCNT
- +9 SET PROGRESS(0)="So far, "_TIUMAPT_" of "_TIUACT_" Active Titles have been mapped!"
- +10 SET PROGRESS(1)=$$PROGRESS(TIUMAPT,TIUACT)
- +11 SET SALUT="Good "_TIUTOD_" "_TIUZR_"!"
- +12 SET GREET=$SELECT(+TIULUSE:"And WELCOME BACK for ANOTHER ride on the MTA!!!",1:"And WELCOME to your FIRST RIDE on the MTA!!!")
- +13 WRITE @IOF,!!?9,"****************************************************************"
- +14 WRITE !?9,"*",$$PAD(SALUT,"L"),SALUT,$$PAD(SALUT,"R"),"*"
- +15 WRITE !?9,"*",$$PAD(GREET,"L"),GREET,$$PAD(GREET,"R"),"*"
- +16 IF '+TIULUSE
- Begin DoDot:1
- +17 WRITE !?9,"* *"
- +18 WRITE !?9,"* This option will help you map your LOCAL TIU Titles to the *"
- +19 WRITE !?9,"* VHA Enterprise Document Type Ontology which VA is helping to *"
- +20 WRITE !?9,"* Develop as an International Normative Standard supporting *"
- +21 WRITE !?9,"* interchange of Clinical Documents. *"
- End DoDot:1
- +22 IF +TIUMAPT>0
- Begin DoDot:1
- +23 WRITE !?9,"* *"
- +24 WRITE !?9,"*",$$PAD(PROGRESS(0),"L"),PROGRESS(0),$$PAD(PROGRESS(0),"R"),"*"
- +25 WRITE !?9,"*",$$PAD(PROGRESS(1),"L"),PROGRESS(1),$$PAD(PROGRESS(1),"R"),"*"
- End DoDot:1
- +26 WRITE !?9,"* *"
- +27 WRITE !?9,"* In preparation for migration to the HDR, ALL LOCAL titles *"
- +28 WRITE !?9,"* MUST be mapped to Standard Titles BEFORE transmittal of TIU *"
- +29 WRITE !?9,"* Documents to the HDR can begin. *"
- +30 WRITE !?9,"* *"
- +31 WRITE !?9,"* You may quit mapping titles at any time, and continue your *"
- +32 WRITE !?9,"* work from the last successfully mapped title. The only *"
- +33 WRITE !?9,"* catch is that any ACTIVE LOCAL Titles that are not mapped *"
- +34 WRITE !?9,"* when transmission to the HDR is initiated will be *"
- +35 WRITE !?9,"* INACTIVATED, so please finish this process expeditiously... *"
- +36 WRITE !?9,"****************************************************************",!
- +37 SET TIUOK=$$READ^TIUU("Y"," ... Are you READY to map","NO")
- if $DATA(DIRUT)
- QUIT
- +38 IF +TIUOK'>0
- WRITE !!?9,$CHAR(7),"... Very well, no damage done!"
- QUIT
- +39 SET ^XTMP("TIUMAP","USER",DUZ)=TIUNOW
- +40 DO LOOP
- +41 QUIT
- PROGRESS(MAPPED,ACTIVE) ; Figure out progress
- +1 NEW TIUI,TIUY,BR,BRSIZE
- SET TIUY="You're at Kendall Square Station..."
- +2 SET BRSIZE=ACTIVE/17
- SET BR=MAPPED\BRSIZE+1
- +3 SET TIUY=$PIECE($TEXT(STOPS+BR),";",3)
- +4 QUIT TIUY
- STOPS ; Get the stops
- +1 ;;You're at Kendall Square Station...Hand in your dime!
- +2 ;;You're at Charles Circle/MGH...
- +3 ;;You're at Park Street Station, changing for Jamaica Plain...
- +4 ;;You're at Boyleston Street Station...
- +5 ;;You're at Arlington Station...
- +6 ;;You're at Copley Station...
- +7 ;;You're at Prudential Station...
- +8 ;;You're at Symphony Station...
- +9 ;;You're at Northeastern University Station...
- +10 ;;You're at Museum of Fine Arts Station...
- +11 ;;You're at Longwood Medical Area Station...
- +12 ;;You're at Brigham Circle Station...
- +13 ;;You're at Fenwood Street Station...
- +14 ;;You're at Mission Park Station...
- +15 ;;You're at Riverway Station...
- +16 ;;You're at Back of the Hill Station...
- +17 ;;You're at Heath Street Station..."One more nickel."
- +18 ;;Wuzzat? NO NICKEL?! Then you'll NEVER return! Ah-HA-Ha-ha!!!
- +19 QUIT
- PAD(MESSAGE,SIDE) ; Compute pad for message
- +1 NEW LEN,PAD
- +2 SET LEN=(64-$LENGTH(MESSAGE))\2
- +3 IF $LENGTH(MESSAGE)#2
- IF SIDE="R"
- SET LEN=LEN+1
- +4 SET $PIECE(PAD," ",LEN)=""
- +5 QUIT PAD
- LOOP ; Loop sequentially through titles
- +1 NEW TIUDA,TIUOUT
- WRITE @IOF
- +2 SET TIUDA=+$GET(^XTMP("TIUMAP","CHKPNT"))
- +3 FOR
- SET TIUDA=$ORDER(^TIU(8925.1,"AT","DOC",TIUDA))
- if TIUDA'>0
- QUIT
- Begin DoDot:1
- +4 NEW TIUD0,TIUNM,TIUTYP,DIRUT
- +5 ; If already mapped, continue to next
- if +$GET(^TIU(8925.1,TIUDA,15))
- QUIT
- +6 SET TIUD0=$GET(^TIU(8925.1,TIUDA,0))
- SET TIUTYP=$PIECE(TIUD0,U,4)
- +7 ; Don't process non-title type document definitions
- +8 if TIUTYP'="DOC"
- QUIT
- +9 ; Only require mapping of ACTIVE local titles
- if +$PIECE(TIUD0,U,7)'=11
- QUIT
- +10 SET TIUNM=$$STRIP^TIUMAP2($PIECE(TIUD0,U))
- +11 LOCK +^TIU(8925.1,TIUDA,15):1
- +12 ; If lock request fails, continue to next title
- IF '$TEST
- QUIT
- +13 WRITE !,"For the LOCAL Title: ",TIUNM,!
- +14 DO MAP(TIUDA,TIUNM)
- +15 ; Decrement lock
- LOCK -^TIU(8925.1,TIUDA,15):1
- +16 if +$GET(TIUOUT)
- QUIT
- +17 IF +$GET(DIRUT)
- Begin DoDot:2
- +18 NEW DIRUT
- +19 if $$READ^TIUU("E")
- WRITE ""
- if +$GET(DIRUT)
- SET TIUOUT=1
- End DoDot:2
- QUIT
- +20 SET ^XTMP("TIUMAP","CHKPNT")=TIUDA
- +21 SET ^XTMP("TIUMAP","MAPCNT")=+$GET(^XTMP("TIUMAP","MAPCNT"))+1
- End DoDot:1
- if +$GET(DIROUT)!+$GET(TIUOUT)
- QUIT
- +22 QUIT
- SINGLES ; Map specific INDIVIDUAL titles
- +1 NEW TIUDA,TIUOUT
- WRITE @IOF
- +2 FOR
- SET TIUDA=+$$LTTL
- Begin DoDot:1
- +3 NEW TIUD0,TIUNM,TIUTYP,DIRUT
- +4 SET TIUD0=$GET(^TIU(8925.1,TIUDA,0))
- SET TIUTYP=$PIECE(TIUD0,U,4)
- +5 ; Don't process non-title type document definitions
- +6 if TIUTYP'="DOC"
- QUIT
- +7 SET TIUNM=$$STRIP^TIUMAP2($PIECE(TIUD0,U))
- +8 if '$$PAGE^TIUMAP2(TIUNM)
- QUIT
- WRITE !!,"For the LOCAL Title: ",TIUNM,!
- +9 DO MAP(TIUDA,TIUNM)
- if +$GET(DIRUT)
- QUIT
- End DoDot:1
- if TIUDA'>0!+$GET(DIROUT)!+$GET(TIUOUT)
- QUIT
- +10 QUIT
- LTTL() ; Call DIC to look-up title
- +1 NEW TIUDA,TIUNM,DIC,X,Y,DTOUT,DUOUT
- +2 SET DIC=8925.1
- SET DIC(0)="AEMQ"
- SET DIC("A")="Select TITLE: "
- +3 SET DIC("S")="I $P(^(0),U,4)=""DOC"",($P(^(0),U,7)=11)"
- +4 DO ^DIC
- KILL DIC("S")
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET DIRUT=1
- if X="^^"
- SET DIROUT=1
- +5 QUIT Y
- ACTCNT() ; Get count of active titles
- +1 NEW TIUI,TIUY,TIUT
- SET (TIUI,TIUT,TIUY)=0
- +2 FOR
- SET TIUI=$ORDER(^TIU(8925.1,"AT","DOC",TIUI))
- if +TIUI'>0
- QUIT
- SET TIUT=TIUT+1
- IF $$ACTIVE(TIUI)
- SET TIUY=TIUY+1
- +3 QUIT TIUY_U_TIUT
- MAPTCNT() ; Get count of mapped titles
- +1 NEW TIUI,TIUY
- SET (TIUI,TIUY)=0
- +2 FOR
- SET TIUI=$ORDER(^TIU(8925.1,"ALOINC",TIUI))
- if +TIUI'>0
- QUIT
- Begin DoDot:1
- +3 NEW TIUJ
- SET TIUJ=0
- +4 FOR
- SET TIUJ=$ORDER(^TIU(8925.1,"ALOINC",TIUI,TIUJ))
- if +TIUJ'>0
- QUIT
- IF $$ACTIVE(TIUJ)
- SET TIUY=TIUY+1
- End DoDot:1
- +5 IF (+$GET(^XTMP("TIUMAP","MAPCNT"))>0)
- IF (^("MAPCNT")'=TIUY)
- SET ^("MAPCNT")=TIUY
- +6 QUIT TIUY
- ACTIVE(TIUDA) ; Is a given title active?
- +1 QUIT $PIECE($GET(^TIU(8925.1,TIUDA,0)),U,7)=11
- MAP(TIUDA,TIUNM) ; Map each LOCAL Title
- +1 NEW RESULT
- SET RESULT=0
- +2 if '$$PAGE^TIUMAP2(TIUNM)
- QUIT
- WRITE !,"Attempting to map ",TIUNM,!?2,"to a VHA Enterprise Standard Title...",!
- +3 ; Bid for LOCK
- +4 LOCK +^TIU(8925.1,TIUDA,15):1
- +5 IF '$TEST
- Begin DoDot:1
- +6 WRITE !,$CHAR(7),"Another user is mapping this title...",!
- +7 if $$READ^TIUU("E")
- WRITE ""
- if +$GET(DIRUT)
- SET TIUOUT=1
- End DoDot:1
- QUIT
- +8 ; First, check whether the LOCAL Title is already mapped
- +9 IF +$GET(^TIU(8925.1,+TIUDA,15))
- Begin DoDot:1
- +10 NEW TIUY
- SET TIUY=0
- +11 WRITE !?5,"The LOCAL Title: ",TIUNM,!?7,"is already mapped to",!,"VHA Enterprise Title: ",$$LOINCNM(+$GET(^TIU(8925.1,+TIUDA,15))),!
- +12 SET TIUY=$$READ^TIUU("YA","Do you want to RE-MAP it? ","NO")
- +13 IF +TIUY'>0
- WRITE $CHAR(7),!,"... OK, No Harm Done!",!
- SET RESULT=-1
- +14 IF '$TEST
- WRITE !
- End DoDot:1
- if RESULT<0!+$GET(DIRUT)
- QUIT
- +15 ; Next, check for an exact match
- +16 SET RESULT=+$ORDER(^TIU(8926.1,"B",TIUNM,RESULT))
- +17 IF RESULT
- Begin DoDot:1
- +18 if '$$PAGE^TIUMAP2(TIUNM)
- QUIT
- WRITE !,"Found Exact Match with VHA Enterprise Standard Title: ",TIUNM,"."
- +19 IF $$SCREEN^XTID(8926.1,"",+RESULT_",")
- Begin DoDot:2
- +20 NEW TIUACT
- +21 WRITE !,"The corresponding VHA Enterprise Standard Title is INACTIVE."
- +22 WRITE !,"You'll need to map ",TIUNM," manually to a different title,",!," or inactivate the local title.",!
- +23 SET RESULT=0
- +24 SET TIUACT=$$READ^TIUU("SA^M:map;I:inactivate","Select action: ","map")
- IF +$GET(DIRUT)
- SET TIUOUT=1
- QUIT
- +25 IF $PIECE(TIUACT,U)="I"
- DO INACT^TIUMAP2(TIUDA)
- QUIT
- +26 IF $PIECE(TIUACT,U)="M"
- WRITE !!,"Attempting to map ",TIUNM," to a different title...",!
- DO PARSE^TIUMAP1(.RESULT,TIUNM)
- End DoDot:2
- if '+RESULT
- QUIT
- +27 SET RESULT(1)=RESULT_U_$PIECE($GET(^TIU(8926.1,+RESULT,0)),U)_U_TIUNM
- +28 DO CONFIRM^TIUMAP1(.RESULT,"Yes")
- +29 IF +RESULT'>0!+$GET(DIRUT)
- DO LOG^TIUMAP1(TIUNM,TIUDA)
- End DoDot:1
- if +RESULT'>0!+$GET(DIRUT)
- QUIT
- IF 1
- +30 ; Otherwise, parse the title, attempting to map each word
- +31 IF '$TEST
- Begin DoDot:1
- +32 DO PARSE^TIUMAP1(.RESULT,TIUNM)
- +33 IF RESULT>0
- IF '+$GET(DIRUT)
- DO CONFIRM^TIUMAP1(.RESULT,"Yes")
- +34 IF +RESULT'>0!+$GET(DIRUT)
- DO LOG^TIUMAP1(TIUNM,TIUDA)
- End DoDot:1
- if +RESULT'>0!+$GET(DIRUT)!+$GET(TIUOUT)
- QUIT
- +35 DO POINT(TIUDA,.RESULT)
- +36 QUIT
- LOINCNM(TIULDA) ; Resolve name of VHA Enterprise Title
- +1 QUIT $PIECE($GET(^TIU(8926.1,+TIULDA,0)),U)
- POINT(DA,RESULT) ; Point the LOCAL Title entry in file #8925.1 at the VHA Enterprise Title
- +1 NEW DIE,DR
- SET DIE="^TIU(8925.1,"
- SET DR="1501////^S X="_+RESULT_";1502////^S X="_$$NOW^XLFDT_";1503////^S X="_DUZ
- +2 DO ^DIE
- WRITE !?13,"Done.",!
- +3 ; Drop LOCK
- +4 LOCK -^TIU(8925.1,DA,15):1
- +5 IF $PIECE($GET(RESULT(1)),U,3)]""
- KILL ^XTMP("TIUMAP","FAIL",$PIECE($GET(RESULT(1)),U,3),DA)
- +6 QUIT