MDSTATU ; HOIFO/NCA - Print List of Document Titles Needed ;10/21/04 13:44
;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
; Reference Integration Agreement:
; IA# 10035 [Supported] Access to DPT file (#2)
; IA# 10039 [Supported] Hospital Location lookup in DIC(42
; IA# 10061 [Supported VADPT calls
; IA# 10104 [Supported] Routine XLFSTR calls
;
DISP ; Display List of TIU titles need to be created for Medicine procedures
W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP Q:POP
I $D(IO("Q")) S ZTRTN="D1^MDSTATU",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTDESC="List Documents Titles Needed",(ZTDTH,ZTIO)="" D ^%ZTLOAD D ^%ZISC W !,"Request Queued" Q
U IO D D1 D ^%ZISC K %ZIS,IOP Q
D1 ; Process Display
N ANS,CNT,DTP,LN,LP,MDK,MDF,MDFIL,MDN,MDN1,MDR,MDTIT,MDV,MDX,PG,S1,TIT,X
S (CNT,PG)=0,ANS="",S1=$S(IOST?1"C".E:IOSL-2,1:IOSL-7) D H1 S MDFIL=8925.1
S LP=0 F S LP=$O(^MDD(703.9,1,1,LP)) Q:LP<1!(ANS="^") S MDF=$G(^(LP,0)) D
.Q:'$P(MDF,U,3)
.S MDTIT=$P(MDF,U,5) Q:MDTIT
.Q:'$P(MDF,U) S MDR="MCAR("_+$P(MDF,U)
.S MDN=0 F S MDN=$O(^MCAR(697.2,"C",MDR,MDN)) Q:MDN<1!(ANS="^") I $G(^MCAR(697.2,MDN,0))'="" D
..S CNT=CNT+1,MDK=$G(^MCAR(697.2,MDN,0)),TIT=$S($P(MDK,U,8)'="":$P(MDK,U,8),1:$P(MDK,U)),TIT=$$UP^XLFSTR(TIT),MDN1=$G(^MCAR(697.2,MDN,1))
..D:$Y'<S1 HDR Q:ANS="^"
..I $P(MDF,U)=699 Q:$P(MDN1,U)="S"
..I $P(MDF,U)=694 Q:$P(MDN1,U)="S"
..I $P(MDF,U)=699.5 Q:$P(MDN1,U)="P"
..S MDV="HISTORICAL "_TIT_$S(TIT["PROCEDURE":"",1:" PROCEDURE")
..S:$L(MDV)>60 MDV=$E(MDV,1,60)
..Q:+$$FIND1^DIC(MDFIL,"","BOX",MDV,"B","","MDERR")
..W !,TIT,?35,MDV
I 'CNT W !!,"No Historical TIU titles need to be created."
W ! Q
PAUSE ; Pause For Scroll
I IOST?1"C".E R !!,"Press RETURN to continue. ",X:DTIME S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PAUSE
Q
DTP ; Printable Date/Time
S %=DTP,DTP=$J(+$E(DTP,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DTP,4,5))_"-"_$E(DTP,2,3)
S:%#1 %=+$E(%_"0",9,10)_"^"_$E(%_"000",11,12),DTP=DTP_$J($S(%>12:%-12,1:+%),3)_":"_$P(%,"^",2)_$S(%<12:"am",%<24:"pm",1:"m") K % Q
HDR ; Display Header and Scroll Pause
D PAUSE Q:ANS="^"
H1 ; Print Header
W:'($E(IOST,1,2)'="C-"&'PG) @IOF
D NOW^%DTC S MDX=%
S PG=PG+1,DTP=MDX D DTP W !,DTP,?20,"L I S T O F T I U T I T L E S N E E D E D",?73,"Page ",PG
W ! S $P(LN,"-",80)="" W !,LN,!
W !,"PROCEDURES",?35,"Titles Needed to be Created"
W !,"----------",?35,"---------------------------",!
Q
SETDEF ; Set default CP Definitions in Conversion Parameter
N MDERR,MDDIEN,MDK,MDF,MDFC,MDFIL,MDFDA,MDLP,MDN,MDNAM,MDOPT,MDR,MDS,MDTAR,MDNAM,MDX,MDY S MDFIL=8925.1 K MDTAR
F MDX=1:1 S MDOPT=$P($T(MEDTIT+MDX),";;",2) Q:MDOPT="**END**" D
.S MDS=$P(MDOPT,";",2)
.S MDY=+$$FIND1^DIC(MDFIL,"","BOX",MDS,"B","","MDERR") Q:'MDY
.S MDTAR(+MDOPT)=+MDY
S MDLP=0 F S MDLP=$O(^MDD(703.9,1,1,MDLP)) Q:MDLP<1 S MDF=$G(^(MDLP,0)) D
.S MDFC=+$P(MDF,U) Q:'MDFC S MDR="MCAR("_MDFC
.Q:MDFC=699
.Q:MDFC=699.5
.Q:MDFC=694
.S (MDK,MDN)=0,MDNAM="" F S MDN=$O(^MCAR(697.2,"C",MDR,MDN)) Q:MDN<1 I $G(^MCAR(697.2,MDN,0))'="" D
..S MDK=$G(^MCAR(697.2,MDN,0)),MDNAM=$S($P(MDK,U,8)'="":$P(MDK,U,8),1:$P(MDK,U)),MDNAM=$$UP^XLFSTR(MDNAM)
.I MDNAM=""&(+$P(MDF,U)=694.5) S MDNAM="CARDIAC SURGERY RISK ASSESSMENT"
.Q:MDNAM=""
.S:$L(MDNAM)<30 MDNAM=MDNAM_" - HIST"
.S:$L(MDNAM)>30 MDNAM=$E(MDNAM,1,30)
.I '$O(^MDS(702.01,"B",MDNAM,0)) D
..Q:$P(MDF,U,2)'=""
..K MDERR,MDDIEN
..S MDFDA(702.01,"+1,",.01)=MDNAM
..D UPDATE^DIE("","MDFDA","MDDIEN","MDERR") Q:$D(MDERR)
..S:+MDDIEN(1) $P(^MDD(703.9,1,1,MDLP,0),U,2)=+MDDIEN(1)
.I $P(MDF,U,5)="" S:+$G(MDTAR(MDFC)) $P(^MDD(703.9,1,1,MDLP,0),U,5)=+$G(MDTAR(MDFC))
Q
GETMED(MDMNO,MDTYPE) ; Get the Medicine Procedure name
N MDI,MDMF,MDLL,MDLL1,MDLL6,MDLL8,MDNA
S MDNA=""
Q:MDTYPE="" MDNA
Q:'+MDMNO MDNA
S MDI=+MDMNO,MDMF=+$P(MDMNO,"MCAR(",2) Q:'MDMF MDNA
I MDMF=699 D
.S (MDLL,MDLL1)=$P($G(^MCAR(699,+MDI,0)),U,12) Q:'MDLL
.S MDLL=$G(^MCAR(697.2,MDLL,0)) Q:MDLL=""
.S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
I MDMF=699.5 D
.S MDLL6=$P($G(^MCAR(699.5,+MDI,0)),U,6) Q:'MDLL6
.S MDLL8=$P($G(^MCAR(699.5,+MDI,0)),U,8) S:MDLL8="" MDLL8=" "
.S MDLL=$G(^MCAR(697.2,MDLL6,0)) Q:MDLL=""
.I MDTYPE="N" S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
.I MDTYPE="P" S MDNA=$E(($E($P(MDLL,U,8),1,13)_"/"_$P($G(^MCAR(697.2,+MDLL8,0)),U)),1,30)
I MDMF=694 D
.S MDLL=$P($G(^MCAR(694,MDI,0)),U,3) Q:'MDLL
.S MDLL=$G(^MCAR(697.2,MDLL,0)) Q:MDLL=""
.S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
S:MDNA'="" MDNA=$$UP^XLFSTR(MDNA)
Q MDNA
LOCATP(MDNNO) ; Locate the CP Definition procedure or Add the New Entry
N MDDIEN,MDERR,MDFDA,MDNM,Y S Y=0
Q:'+MDNNO 0 S MDMNO=MDNNO
S MDNM=$$GETMED(MDMNO,"P") Q:MDNM="" Y
S MDNM=MDNM_" - HIST" S:$L(MDNM)>30 MDNM=$E(MDNM,1,30)
S Y=$O(^MDS(702.01,"B",MDNM,0)) Q:+Y Y
S MDFDA(702.01,"+1,",.01)=MDNM
D UPDATE^DIE("","MDFDA","MDDIEN","MDERR") Q:$D(MDERR)
S Y=+MDDIEN(1)
Q Y
LOCATN(MDNNO) ; Locate the Historical Document Title
N MDDIEN,MDERR,MDFDA,MDNM,MDT,MDV,Y S Y=0,MDV=8925.1
Q:'+MDNNO 0 S MDMNO=MDNNO
S MDNM=$$GETMED(MDMNO,"N") Q:MDNM="" Y
S MDT="HISTORICAL "_MDNM_$S(MDNM["PROCEDURE":"",1:" PROCEDURE")
S Y=+$$FIND1^DIC(MDV,"","BOX",MDT,"B","","MDERR")
Q Y
HOSP(MDNNO) ; Locate the Hospital Location
N MDERR,MDI,MDMF,MDOPT,MDL,MDS,MDTAR,MDV,MDW,MDW1,MDX
S MDL=0 K MDTAR
Q:'+MDNNO MDL
S MDI=+MDNNO,MDMF=+$P(MDNNO,"MCAR(",2) Q:'MDMF MDL
F MDX=1:1 S MDOPT=$P($T(MEDTIT+MDX),";;",2) Q:MDOPT="**END**" D
.S MDS=$P(MDOPT,";",3,4)
.S MDTAR(+MDOPT)=MDS
S MDS=$G(MDTAR(MDMF))
S:+$P(MDS,";",2) MDL=$P($G(^MCAR(MDMF,MDI,$P(MDS,";"))),"^",+$P(MDS,";",2))
I 'MDL D
.S DFN=+$P($G(^MCAR(MDMF,MDI,0)),U,2),VAIP("D")=$P($G(^MCAR(MDMF,MDI,0)),U,1)
.D IN5^VADPT S MDW=+VAIP(5) D KVAR^VADPT S:MDW MDL=+$P($G(^DIC(42,+MDW,44)),U)
.I 'MDL S MDW=$G(^DPT(DFN,.1)) I MDW'="" S MDV=42,MDW1=$$FIND1^DIC(MDV,"","BOX",MDW,"B","","MDERR") S:MDW1 MDL=+$P($G(^DIC(42,+MDW1,44)),U)
Q MDL
MEDTIT ;; [Medicine Historical Document Titles]
;;691.1;HISTORICAL CARDIAC CATHETERIZATION PROCEDURE;0;6
;;691;HISTORICAL ECHOCARDIOGRAM PROCEDURE;11;2
;;691.5;HISTORICAL ELECTROCARDIOGRAM PROCEDURE;8;1
;;691.8;HISTORICAL ELECTROPHYSIOLOGY PROCEDURE;15;3
;;691.7;HISTORICAL EXERCISE TOLERANCE TEST PROCEDURE;10;5
;;691.6;HISTORICAL HOLTER PROCEDURE;0;18
;;698;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
;;698.1;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
;;698.2;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
;;698.3;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
;;694.5;HISTORICAL PRE/POST SURGERY RISK NOTE
;;694; ;0;4
;;699; ;0;11
;;700;HISTORICAL PULMONARY FUNCTION TEST PROCEDURE;0;10
;;701;HISTORICAL RHEUMATOLOGY PROCEDURE
;;**END**
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDSTATU 6876 printed Sep 23, 2025@19:20:20 Page 2
MDSTATU ; HOIFO/NCA - Print List of Document Titles Needed ;10/21/04 13:44
+1 ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
+2 ; Reference Integration Agreement:
+3 ; IA# 10035 [Supported] Access to DPT file (#2)
+4 ; IA# 10039 [Supported] Hospital Location lookup in DIC(42
+5 ; IA# 10061 [Supported VADPT calls
+6 ; IA# 10104 [Supported] Routine XLFSTR calls
+7 ;
DISP ; Display List of TIU titles need to be created for Medicine procedures
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
QUIT
+2 IF $DATA(IO("Q"))
SET ZTRTN="D1^MDSTATU"
SET ZTREQ="@"
SET ZTSAVE("ZTREQ")=""
SET ZTDESC="List Documents Titles Needed"
SET (ZTDTH,ZTIO)=""
DO ^%ZTLOAD
DO ^%ZISC
WRITE !,"Request Queued"
QUIT
+3 USE IO
DO D1
DO ^%ZISC
KILL %ZIS,IOP
QUIT
D1 ; Process Display
+1 NEW ANS,CNT,DTP,LN,LP,MDK,MDF,MDFIL,MDN,MDN1,MDR,MDTIT,MDV,MDX,PG,S1,TIT,X
+2 SET (CNT,PG)=0
SET ANS=""
SET S1=$SELECT(IOST?1"C".E:IOSL-2,1:IOSL-7)
DO H1
SET MDFIL=8925.1
+3 SET LP=0
FOR
SET LP=$ORDER(^MDD(703.9,1,1,LP))
if LP<1!(ANS="^")
QUIT
SET MDF=$GET(^(LP,0))
Begin DoDot:1
+4 if '$PIECE(MDF,U,3)
QUIT
+5 SET MDTIT=$PIECE(MDF,U,5)
if MDTIT
QUIT
+6 if '$PIECE(MDF,U)
QUIT
SET MDR="MCAR("_+$PIECE(MDF,U)
+7 SET MDN=0
FOR
SET MDN=$ORDER(^MCAR(697.2,"C",MDR,MDN))
if MDN<1!(ANS="^")
QUIT
IF $GET(^MCAR(697.2,MDN,0))'=""
Begin DoDot:2
+8 SET CNT=CNT+1
SET MDK=$GET(^MCAR(697.2,MDN,0))
SET TIT=$SELECT($PIECE(MDK,U,8)'="":$PIECE(MDK,U,8),1:$PIECE(MDK,U))
SET TIT=$$UP^XLFSTR(TIT)
SET MDN1=$GET(^MCAR(697.2,MDN,1))
+9 if $Y'<S1
DO HDR
if ANS="^"
QUIT
+10 IF $PIECE(MDF,U)=699
if $PIECE(MDN1,U)="S"
QUIT
+11 IF $PIECE(MDF,U)=694
if $PIECE(MDN1,U)="S"
QUIT
+12 IF $PIECE(MDF,U)=699.5
if $PIECE(MDN1,U)="P"
QUIT
+13 SET MDV="HISTORICAL "_TIT_$SELECT(TIT["PROCEDURE":"",1:" PROCEDURE")
+14 if $LENGTH(MDV)>60
SET MDV=$EXTRACT(MDV,1,60)
+15 if +$$FIND1^DIC(MDFIL,"","BOX",MDV,"B","","MDERR")
QUIT
+16 WRITE !,TIT,?35,MDV
End DoDot:2
End DoDot:1
+17 IF 'CNT
WRITE !!,"No Historical TIU titles need to be created."
+18 WRITE !
QUIT
PAUSE ; Pause For Scroll
+1 IF IOST?1"C".E
READ !!,"Press RETURN to continue. ",X:DTIME
if '$TEST!(X["^")
SET ANS="^"
if ANS="^"
QUIT
IF "^"'[X
WRITE !,"Enter a RETURN to Continue."
GOTO PAUSE
+2 QUIT
DTP ; Printable Date/Time
+1 SET %=DTP
SET DTP=$JUSTIFY(+$EXTRACT(DTP,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(DTP,4,5))_"-"_$EXTRACT(DTP,2,3)
+2 if %#1
SET %=+$EXTRACT(%_"0",9,10)_"^"_$EXTRACT(%_"000",11,12)
SET DTP=DTP_$JUSTIFY($SELECT(%>12:%-12,1:+%),3)_":"_$PIECE(%,"^",2)_$SELECT(%<12:"am",%<24:"pm",1:"m")
KILL %
QUIT
HDR ; Display Header and Scroll Pause
+1 DO PAUSE
if ANS="^"
QUIT
H1 ; Print Header
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
+2 DO NOW^%DTC
SET MDX=%
+3 SET PG=PG+1
SET DTP=MDX
DO DTP
WRITE !,DTP,?20,"L I S T O F T I U T I T L E S N E E D E D",?73,"Page ",PG
+4 WRITE !
SET $PIECE(LN,"-",80)=""
WRITE !,LN,!
+5 WRITE !,"PROCEDURES",?35,"Titles Needed to be Created"
+6 WRITE !,"----------",?35,"---------------------------",!
+7 QUIT
SETDEF ; Set default CP Definitions in Conversion Parameter
+1 NEW MDERR,MDDIEN,MDK,MDF,MDFC,MDFIL,MDFDA,MDLP,MDN,MDNAM,MDOPT,MDR,MDS,MDTAR,MDNAM,MDX,MDY
SET MDFIL=8925.1
KILL MDTAR
+2 FOR MDX=1:1
SET MDOPT=$PIECE($TEXT(MEDTIT+MDX),";;",2)
if MDOPT="**END**"
QUIT
Begin DoDot:1
+3 SET MDS=$PIECE(MDOPT,";",2)
+4 SET MDY=+$$FIND1^DIC(MDFIL,"","BOX",MDS,"B","","MDERR")
if 'MDY
QUIT
+5 SET MDTAR(+MDOPT)=+MDY
End DoDot:1
+6 SET MDLP=0
FOR
SET MDLP=$ORDER(^MDD(703.9,1,1,MDLP))
if MDLP<1
QUIT
SET MDF=$GET(^(MDLP,0))
Begin DoDot:1
+7 SET MDFC=+$PIECE(MDF,U)
if 'MDFC
QUIT
SET MDR="MCAR("_MDFC
+8 if MDFC=699
QUIT
+9 if MDFC=699.5
QUIT
+10 if MDFC=694
QUIT
+11 SET (MDK,MDN)=0
SET MDNAM=""
FOR
SET MDN=$ORDER(^MCAR(697.2,"C",MDR,MDN))
if MDN<1
QUIT
IF $GET(^MCAR(697.2,MDN,0))'=""
Begin DoDot:2
+12 SET MDK=$GET(^MCAR(697.2,MDN,0))
SET MDNAM=$SELECT($PIECE(MDK,U,8)'="":$PIECE(MDK,U,8),1:$PIECE(MDK,U))
SET MDNAM=$$UP^XLFSTR(MDNAM)
End DoDot:2
+13 IF MDNAM=""&(+$PIECE(MDF,U)=694.5)
SET MDNAM="CARDIAC SURGERY RISK ASSESSMENT"
+14 if MDNAM=""
QUIT
+15 if $LENGTH(MDNAM)<30
SET MDNAM=MDNAM_" - HIST"
+16 if $LENGTH(MDNAM)>30
SET MDNAM=$EXTRACT(MDNAM,1,30)
+17 IF '$ORDER(^MDS(702.01,"B",MDNAM,0))
Begin DoDot:2
+18 if $PIECE(MDF,U,2)'=""
QUIT
+19 KILL MDERR,MDDIEN
+20 SET MDFDA(702.01,"+1,",.01)=MDNAM
+21 DO UPDATE^DIE("","MDFDA","MDDIEN","MDERR")
if $DATA(MDERR)
QUIT
+22 if +MDDIEN(1)
SET $PIECE(^MDD(703.9,1,1,MDLP,0),U,2)=+MDDIEN(1)
End DoDot:2
+23 IF $PIECE(MDF,U,5)=""
if +$GET(MDTAR(MDFC))
SET $PIECE(^MDD(703.9,1,1,MDLP,0),U,5)=+$GET(MDTAR(MDFC))
End DoDot:1
+24 QUIT
GETMED(MDMNO,MDTYPE) ; Get the Medicine Procedure name
+1 NEW MDI,MDMF,MDLL,MDLL1,MDLL6,MDLL8,MDNA
+2 SET MDNA=""
+3 if MDTYPE=""
QUIT MDNA
+4 if '+MDMNO
QUIT MDNA
+5 SET MDI=+MDMNO
SET MDMF=+$PIECE(MDMNO,"MCAR(",2)
if 'MDMF
QUIT MDNA
+6 IF MDMF=699
Begin DoDot:1
+7 SET (MDLL,MDLL1)=$PIECE($GET(^MCAR(699,+MDI,0)),U,12)
if 'MDLL
QUIT
+8 SET MDLL=$GET(^MCAR(697.2,MDLL,0))
if MDLL=""
QUIT
+9 SET MDNA=$SELECT($PIECE(MDLL,U,8)'="":$PIECE(MDLL,U,8),1:$PIECE(MDLL,U))
QUIT
End DoDot:1
+10 IF MDMF=699.5
Begin DoDot:1
+11 SET MDLL6=$PIECE($GET(^MCAR(699.5,+MDI,0)),U,6)
if 'MDLL6
QUIT
+12 SET MDLL8=$PIECE($GET(^MCAR(699.5,+MDI,0)),U,8)
if MDLL8=""
SET MDLL8=" "
+13 SET MDLL=$GET(^MCAR(697.2,MDLL6,0))
if MDLL=""
QUIT
+14 IF MDTYPE="N"
SET MDNA=$SELECT($PIECE(MDLL,U,8)'="":$PIECE(MDLL,U,8),1:$PIECE(MDLL,U))
QUIT
+15 IF MDTYPE="P"
SET MDNA=$EXTRACT(($EXTRACT($PIECE(MDLL,U,8),1,13)_"/"_$PIECE($GET(^MCAR(697.2,+MDLL8,0)),U)),1,30)
End DoDot:1
+16 IF MDMF=694
Begin DoDot:1
+17 SET MDLL=$PIECE($GET(^MCAR(694,MDI,0)),U,3)
if 'MDLL
QUIT
+18 SET MDLL=$GET(^MCAR(697.2,MDLL,0))
if MDLL=""
QUIT
+19 SET MDNA=$SELECT($PIECE(MDLL,U,8)'="":$PIECE(MDLL,U,8),1:$PIECE(MDLL,U))
QUIT
End DoDot:1
+20 if MDNA'=""
SET MDNA=$$UP^XLFSTR(MDNA)
+21 QUIT MDNA
LOCATP(MDNNO) ; Locate the CP Definition procedure or Add the New Entry
+1 NEW MDDIEN,MDERR,MDFDA,MDNM,Y
SET Y=0
+2 if '+MDNNO
QUIT 0
SET MDMNO=MDNNO
+3 SET MDNM=$$GETMED(MDMNO,"P")
if MDNM=""
QUIT Y
+4 SET MDNM=MDNM_" - HIST"
if $LENGTH(MDNM)>30
SET MDNM=$EXTRACT(MDNM,1,30)
+5 SET Y=$ORDER(^MDS(702.01,"B",MDNM,0))
if +Y
QUIT Y
+6 SET MDFDA(702.01,"+1,",.01)=MDNM
+7 DO UPDATE^DIE("","MDFDA","MDDIEN","MDERR")
if $DATA(MDERR)
QUIT
+8 SET Y=+MDDIEN(1)
+9 QUIT Y
LOCATN(MDNNO) ; Locate the Historical Document Title
+1 NEW MDDIEN,MDERR,MDFDA,MDNM,MDT,MDV,Y
SET Y=0
SET MDV=8925.1
+2 if '+MDNNO
QUIT 0
SET MDMNO=MDNNO
+3 SET MDNM=$$GETMED(MDMNO,"N")
if MDNM=""
QUIT Y
+4 SET MDT="HISTORICAL "_MDNM_$SELECT(MDNM["PROCEDURE":"",1:" PROCEDURE")
+5 SET Y=+$$FIND1^DIC(MDV,"","BOX",MDT,"B","","MDERR")
+6 QUIT Y
HOSP(MDNNO) ; Locate the Hospital Location
+1 NEW MDERR,MDI,MDMF,MDOPT,MDL,MDS,MDTAR,MDV,MDW,MDW1,MDX
+2 SET MDL=0
KILL MDTAR
+3 if '+MDNNO
QUIT MDL
+4 SET MDI=+MDNNO
SET MDMF=+$PIECE(MDNNO,"MCAR(",2)
if 'MDMF
QUIT MDL
+5 FOR MDX=1:1
SET MDOPT=$PIECE($TEXT(MEDTIT+MDX),";;",2)
if MDOPT="**END**"
QUIT
Begin DoDot:1
+6 SET MDS=$PIECE(MDOPT,";",3,4)
+7 SET MDTAR(+MDOPT)=MDS
End DoDot:1
+8 SET MDS=$GET(MDTAR(MDMF))
+9 if +$PIECE(MDS,";",2)
SET MDL=$PIECE($GET(^MCAR(MDMF,MDI,$PIECE(MDS,";"))),"^",+$PIECE(MDS,";",2))
+10 IF 'MDL
Begin DoDot:1
+11 SET DFN=+$PIECE($GET(^MCAR(MDMF,MDI,0)),U,2)
SET VAIP("D")=$PIECE($GET(^MCAR(MDMF,MDI,0)),U,1)
+12 DO IN5^VADPT
SET MDW=+VAIP(5)
DO KVAR^VADPT
if MDW
SET MDL=+$PIECE($GET(^DIC(42,+MDW,44)),U)
+13 IF 'MDL
SET MDW=$GET(^DPT(DFN,.1))
IF MDW'=""
SET MDV=42
SET MDW1=$$FIND1^DIC(MDV,"","BOX",MDW,"B","","MDERR")
if MDW1
SET MDL=+$PIECE($GET(^DIC(42,+MDW1,44)),U)
End DoDot:1
+14 QUIT MDL
MEDTIT ;; [Medicine Historical Document Titles]
+1 ;;691.1;HISTORICAL CARDIAC CATHETERIZATION PROCEDURE;0;6
+2 ;;691;HISTORICAL ECHOCARDIOGRAM PROCEDURE;11;2
+3 ;;691.5;HISTORICAL ELECTROCARDIOGRAM PROCEDURE;8;1
+4 ;;691.8;HISTORICAL ELECTROPHYSIOLOGY PROCEDURE;15;3
+5 ;;691.7;HISTORICAL EXERCISE TOLERANCE TEST PROCEDURE;10;5
+6 ;;691.6;HISTORICAL HOLTER PROCEDURE;0;18
+7 ;;698;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
+8 ;;698.1;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
+9 ;;698.2;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
+10 ;;698.3;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
+11 ;;694.5;HISTORICAL PRE/POST SURGERY RISK NOTE
+12 ;;694; ;0;4
+13 ;;699; ;0;11
+14 ;;700;HISTORICAL PULMONARY FUNCTION TEST PROCEDURE;0;10
+15 ;;701;HISTORICAL RHEUMATOLOGY PROCEDURE
+16 ;;**END**
