Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MDSTATU

MDSTATU.m

Go to the documentation of this file.
  1. 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
  1. ; Reference Integration Agreement:
  1. ; IA# 10035 [Supported] Access to DPT file (#2)
  1. ; IA# 10039 [Supported] Hospital Location lookup in DIC(42
  1. ; IA# 10061 [Supported VADPT calls
  1. ; IA# 10104 [Supported] Routine XLFSTR calls
  1. ;
  1. DISP ; Display List of TIU titles need to be created for Medicine procedures
  1. W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP Q:POP
  1. 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
  1. U IO D D1 D ^%ZISC K %ZIS,IOP Q
  1. D1 ; Process Display
  1. N ANS,CNT,DTP,LN,LP,MDK,MDF,MDFIL,MDN,MDN1,MDR,MDTIT,MDV,MDX,PG,S1,TIT,X
  1. S (CNT,PG)=0,ANS="",S1=$S(IOST?1"C".E:IOSL-2,1:IOSL-7) D H1 S MDFIL=8925.1
  1. S LP=0 F S LP=$O(^MDD(703.9,1,1,LP)) Q:LP<1!(ANS="^") S MDF=$G(^(LP,0)) D
  1. .Q:'$P(MDF,U,3)
  1. .S MDTIT=$P(MDF,U,5) Q:MDTIT
  1. .Q:'$P(MDF,U) S MDR="MCAR("_+$P(MDF,U)
  1. .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
  1. ..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))
  1. ..D:$Y'<S1 HDR Q:ANS="^"
  1. ..I $P(MDF,U)=699 Q:$P(MDN1,U)="S"
  1. ..I $P(MDF,U)=694 Q:$P(MDN1,U)="S"
  1. ..I $P(MDF,U)=699.5 Q:$P(MDN1,U)="P"
  1. ..S MDV="HISTORICAL "_TIT_$S(TIT["PROCEDURE":"",1:" PROCEDURE")
  1. ..S:$L(MDV)>60 MDV=$E(MDV,1,60)
  1. ..Q:+$$FIND1^DIC(MDFIL,"","BOX",MDV,"B","","MDERR")
  1. ..W !,TIT,?35,MDV
  1. I 'CNT W !!,"No Historical TIU titles need to be created."
  1. W ! Q
  1. PAUSE ; Pause For Scroll
  1. 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
  1. Q
  1. DTP ; Printable Date/Time
  1. 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)
  1. 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
  1. HDR ; Display Header and Scroll Pause
  1. D PAUSE Q:ANS="^"
  1. H1 ; Print Header
  1. W:'($E(IOST,1,2)'="C-"&'PG) @IOF
  1. D NOW^%DTC S MDX=%
  1. 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
  1. W ! S $P(LN,"-",80)="" W !,LN,!
  1. W !,"PROCEDURES",?35,"Titles Needed to be Created"
  1. W !,"----------",?35,"---------------------------",!
  1. Q
  1. SETDEF ; Set default CP Definitions in Conversion Parameter
  1. N MDERR,MDDIEN,MDK,MDF,MDFC,MDFIL,MDFDA,MDLP,MDN,MDNAM,MDOPT,MDR,MDS,MDTAR,MDNAM,MDX,MDY S MDFIL=8925.1 K MDTAR
  1. F MDX=1:1 S MDOPT=$P($T(MEDTIT+MDX),";;",2) Q:MDOPT="**END**" D
  1. .S MDS=$P(MDOPT,";",2)
  1. .S MDY=+$$FIND1^DIC(MDFIL,"","BOX",MDS,"B","","MDERR") Q:'MDY
  1. .S MDTAR(+MDOPT)=+MDY
  1. S MDLP=0 F S MDLP=$O(^MDD(703.9,1,1,MDLP)) Q:MDLP<1 S MDF=$G(^(MDLP,0)) D
  1. .S MDFC=+$P(MDF,U) Q:'MDFC S MDR="MCAR("_MDFC
  1. .Q:MDFC=699
  1. .Q:MDFC=699.5
  1. .Q:MDFC=694
  1. .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
  1. ..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)
  1. .I MDNAM=""&(+$P(MDF,U)=694.5) S MDNAM="CARDIAC SURGERY RISK ASSESSMENT"
  1. .Q:MDNAM=""
  1. .S:$L(MDNAM)<30 MDNAM=MDNAM_" - HIST"
  1. .S:$L(MDNAM)>30 MDNAM=$E(MDNAM,1,30)
  1. .I '$O(^MDS(702.01,"B",MDNAM,0)) D
  1. ..Q:$P(MDF,U,2)'=""
  1. ..K MDERR,MDDIEN
  1. ..S MDFDA(702.01,"+1,",.01)=MDNAM
  1. ..D UPDATE^DIE("","MDFDA","MDDIEN","MDERR") Q:$D(MDERR)
  1. ..S:+MDDIEN(1) $P(^MDD(703.9,1,1,MDLP,0),U,2)=+MDDIEN(1)
  1. .I $P(MDF,U,5)="" S:+$G(MDTAR(MDFC)) $P(^MDD(703.9,1,1,MDLP,0),U,5)=+$G(MDTAR(MDFC))
  1. Q
  1. GETMED(MDMNO,MDTYPE) ; Get the Medicine Procedure name
  1. N MDI,MDMF,MDLL,MDLL1,MDLL6,MDLL8,MDNA
  1. S MDNA=""
  1. Q:MDTYPE="" MDNA
  1. Q:'+MDMNO MDNA
  1. S MDI=+MDMNO,MDMF=+$P(MDMNO,"MCAR(",2) Q:'MDMF MDNA
  1. I MDMF=699 D
  1. .S (MDLL,MDLL1)=$P($G(^MCAR(699,+MDI,0)),U,12) Q:'MDLL
  1. .S MDLL=$G(^MCAR(697.2,MDLL,0)) Q:MDLL=""
  1. .S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
  1. I MDMF=699.5 D
  1. .S MDLL6=$P($G(^MCAR(699.5,+MDI,0)),U,6) Q:'MDLL6
  1. .S MDLL8=$P($G(^MCAR(699.5,+MDI,0)),U,8) S:MDLL8="" MDLL8=" "
  1. .S MDLL=$G(^MCAR(697.2,MDLL6,0)) Q:MDLL=""
  1. .I MDTYPE="N" S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
  1. .I MDTYPE="P" S MDNA=$E(($E($P(MDLL,U,8),1,13)_"/"_$P($G(^MCAR(697.2,+MDLL8,0)),U)),1,30)
  1. I MDMF=694 D
  1. .S MDLL=$P($G(^MCAR(694,MDI,0)),U,3) Q:'MDLL
  1. .S MDLL=$G(^MCAR(697.2,MDLL,0)) Q:MDLL=""
  1. .S MDNA=$S($P(MDLL,U,8)'="":$P(MDLL,U,8),1:$P(MDLL,U)) Q
  1. S:MDNA'="" MDNA=$$UP^XLFSTR(MDNA)
  1. Q MDNA
  1. LOCATP(MDNNO) ; Locate the CP Definition procedure or Add the New Entry
  1. N MDDIEN,MDERR,MDFDA,MDNM,Y S Y=0
  1. Q:'+MDNNO 0 S MDMNO=MDNNO
  1. S MDNM=$$GETMED(MDMNO,"P") Q:MDNM="" Y
  1. S MDNM=MDNM_" - HIST" S:$L(MDNM)>30 MDNM=$E(MDNM,1,30)
  1. S Y=$O(^MDS(702.01,"B",MDNM,0)) Q:+Y Y
  1. S MDFDA(702.01,"+1,",.01)=MDNM
  1. D UPDATE^DIE("","MDFDA","MDDIEN","MDERR") Q:$D(MDERR)
  1. S Y=+MDDIEN(1)
  1. Q Y
  1. LOCATN(MDNNO) ; Locate the Historical Document Title
  1. N MDDIEN,MDERR,MDFDA,MDNM,MDT,MDV,Y S Y=0,MDV=8925.1
  1. Q:'+MDNNO 0 S MDMNO=MDNNO
  1. S MDNM=$$GETMED(MDMNO,"N") Q:MDNM="" Y
  1. S MDT="HISTORICAL "_MDNM_$S(MDNM["PROCEDURE":"",1:" PROCEDURE")
  1. S Y=+$$FIND1^DIC(MDV,"","BOX",MDT,"B","","MDERR")
  1. Q Y
  1. HOSP(MDNNO) ; Locate the Hospital Location
  1. N MDERR,MDI,MDMF,MDOPT,MDL,MDS,MDTAR,MDV,MDW,MDW1,MDX
  1. S MDL=0 K MDTAR
  1. Q:'+MDNNO MDL
  1. S MDI=+MDNNO,MDMF=+$P(MDNNO,"MCAR(",2) Q:'MDMF MDL
  1. F MDX=1:1 S MDOPT=$P($T(MEDTIT+MDX),";;",2) Q:MDOPT="**END**" D
  1. .S MDS=$P(MDOPT,";",3,4)
  1. .S MDTAR(+MDOPT)=MDS
  1. S MDS=$G(MDTAR(MDMF))
  1. S:+$P(MDS,";",2) MDL=$P($G(^MCAR(MDMF,MDI,$P(MDS,";"))),"^",+$P(MDS,";",2))
  1. I 'MDL D
  1. .S DFN=+$P($G(^MCAR(MDMF,MDI,0)),U,2),VAIP("D")=$P($G(^MCAR(MDMF,MDI,0)),U,1)
  1. .D IN5^VADPT S MDW=+VAIP(5) D KVAR^VADPT S:MDW MDL=+$P($G(^DIC(42,+MDW,44)),U)
  1. .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)
  1. Q MDL
  1. MEDTIT ;; [Medicine Historical Document Titles]
  1. ;;691.1;HISTORICAL CARDIAC CATHETERIZATION PROCEDURE;0;6
  1. ;;691;HISTORICAL ECHOCARDIOGRAM PROCEDURE;11;2
  1. ;;691.5;HISTORICAL ELECTROCARDIOGRAM PROCEDURE;8;1
  1. ;;691.8;HISTORICAL ELECTROPHYSIOLOGY PROCEDURE;15;3
  1. ;;691.7;HISTORICAL EXERCISE TOLERANCE TEST PROCEDURE;10;5
  1. ;;691.6;HISTORICAL HOLTER PROCEDURE;0;18
  1. ;;698;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
  1. ;;698.1;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
  1. ;;698.2;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
  1. ;;698.3;HISTORICAL PACEMAKER IMPLANTATION PROCEDURE
  1. ;;694.5;HISTORICAL PRE/POST SURGERY RISK NOTE
  1. ;;694; ;0;4
  1. ;;699; ;0;11
  1. ;;700;HISTORICAL PULMONARY FUNCTION TEST PROCEDURE;0;10
  1. ;;701;HISTORICAL RHEUMATOLOGY PROCEDURE
  1. ;;**END**