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

MCARE.m

Go to the documentation of this file.
  1. MCARE ;WISC/RMP-EDIT ROUTINES ;1/23/03 20:45
  1. ;;2.3;Medicine;**35**;09/13/1996
  1. ; Reference IA #3746 for ^DD(file#,0,"ID") Access
  1. ; #10076 for ^XUSEC
  1. ; #10061 FOR ^VADPT call.
  1. ENTER ;ENTER NEW CARDIAC PROCEDURES (SCREEN HANDLER)
  1. ;SELECT GLOBAL AND PROCEDURE NAME FROM PROCEDURE LOCATION FILE
  1. D MCEPROC
  1. S MCARGNUM=MCARP,DIC=^DIC(MCFILE,0,"GL")
  1. S DJSC=MCEPROC,USEREND=1
  1. S DIC(0)="AELMQZ",(DLAYGO,DIDEL)=+$P(DIC,"(",2)
  1. S (MCARGNAM,MCARP)=$P(^MCAR(697.2,MCARP,0),U,1)
  1. DATE ;SELECT PROCEDURE DATE
  1. I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
  1. ;S DR=MCPATFLD
  1. D DATE^MCAREH ; guidance for the date prompt
  1. D ^DIC K DIC,DLAYGO
  1. ;CONDITIONAL ENTRY DELETE CODE HERE
  1. I Y'=-1 D EXISTS ; an entry exists, so take an action
  1. EXIT ;
  1. D KVAR^VADPT
  1. K X,Y,MCARP,DJSC,MCARPT,DIC,DJDN,DR,DIE,MCARGDA,MCARGNUM
  1. K DLAYGO,MCARNUM,MCARNM,DFN,DIDEL,MCFILE,MCARDE,MCSEX,MCRACE,MCFILE
  1. K %,%H,%X,%Y,%Y1,%Y2,D0,D1,D2,DI,DIW,DIWI,DIWT,DIWTC,DIWX,DIZ,DN,DQ
  1. K I,J,VA,X1,Y,Z,DJVV,%T,DIPGM,DW1,DTOUT,DUOUT,MCESS,ID2
  1. K DIC,DIK,DIE,DFN,DA,MCARGNUM,MCARGNAM,DR,MCX,SSN,MCARCODE,%,MCORCK
  1. K C,MCARAPDT,CD,MCARCDIE,MCAROLDT,XX,DIH,DIR,S,DX,DIU,DIV,DZ,MCARFIND
  1. K MCSPHIN,MCSTENT,MCBOUGIE,MCGTUBE,MCJTUBE,MCHEATP,MCDFLAG,MCARI
  1. K MCARNP,MCARTOT,DIDEL,DTOUT,DUOUT,MCESFL,EXIT,MCBACK,MCESPREV
  1. K MCESCUR,MCESTEMP,MCARCK,MCARDA,MCARDE,MCARP,MCESKEY,MCESON
  1. K MCESPED,MCESS,MCESSEC,MCFILE,MCFILE1,MCPATFLD,MCPOSTP,MCROUT
  1. K POP,MCPCT,MCPCTY,TEP,MCARDE,MCARP,MCESKEY,MCESON,MCESS
  1. Q
  1. EXISTS ;
  1. S DFN=$P(Y(0),U,2) ; patient number
  1. S (DJDN,MCARGDA)=$P(Y,U,1)
  1. I MCFILE=700 S MCRACE=$$RACECDE^MCPFTSS(DFN) K:MCRACE="" MCRACE
  1. I MCFILE=691.5,$D(^MCAR(MCFILE,MCARGDA,"A")) Q:'MCESON D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q
  1. I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q
  1. ; set certain variables based upon file selected
  1. I MCFILE=691.8 S MCARZDN=DJDN
  1. D IN^MCEO ; order entry
  1. I '$D(DTOUT),'$D(DUOUT) D
  1. .D EN^MCARD I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK
  1. .I $L(MCPOSTP)>1 S X=MCPOSTP X ^%ZOSF("TEST") D:$T @MCPOSTP
  1. .D OUT^MCEO K DIDEL
  1. I MCFILE=691.8,$D(^MCAR(MCFILE,MCARGDA,0)) D EN4^MCARATVE ; atrial/ventricular studies
  1. D ESRC^MCESSCR(MCFILE,MCARGDA)
  1. I $L($G(MCRACE))>1 D
  1. .I $$GET1^DIQ(700,+MCARGDA_",",38,"E")="YES"&($$GET1^DIQ(700,+MCARGDA,38.5,"E")="") D
  1. ..N MCFDA
  1. ..S MCFDA(700,+MCARGDA_",",38)=""
  1. ..D FILE^DIE("","MCFDA")
  1. ..W !!?5,"*** Patient has both race values BLACK and ASIAN. ***"
  1. ..W !?5,"*** MUST enter a value for the RACE CORRECTIONS FOR RACE TYPE field.***"
  1. ..W !?5,"*** USE RACE CORRECTIONS field will be set to NULL. ***"
  1. ..Q
  1. .Q
  1. Q
  1. BACK ; If the record is superseded, the user will be allow to edit the superseded record.
  1. S Y=MCY,DA=Y,Y(0)=MCY(0),Y(0,0)=MCY(0,0) K MCY,DTOUT,DIROUT,DUOUT,DIC
  1. G EXISTS
  1. Q
  1. HELP G EXIT:(X=U)!(X="") W !,"ENTER A NEW PROCEDURE DATE" G DATE
  1. EDIT Q ; MFR 28 JAN 93 ;EDIT CARDIAC PROCEDURES BY PATIENT (SCREEN HANDLER)
  1. ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE
  1. S MCARGNUM=MCARP,MCARLK="^MCAR("_MCFILE
  1. S MCARLK=U_MCARLK_",""C"",+Y)"
  1. S DIC("S")="I $D(@(MCARLK))"
  1. S DIC="^MCAR(690,",DIC(0)="AEQM" D ^DIC K MCARLK I Y<0 G EXIT
  1. W !,MCARDE," PROCEDURES"
  1. ;SELECT PROCEDURE DATE
  1. S (MCARPT,DFN)=+Y
  1. D DEM^VADPT S MCARNM=VADM(1) D KVAR^VADPT
  1. S DIC("W")="",DIC("S")="I $P(^(0),U,2)=+MCARPT",DIC=U_$P(^MCAR(697.2,MCARP,0),U,2)_",",D="C",DJSC=$S($G(MCBS)=1:$P(^MCAR(697.2,MCARP,0),U,13),1:$P(^(0),U,3)),(MCFILE,DIDEL)=+$P(DIC,"(",2)
  1. S X=MCARNM,DIC(0)="EQ" D IX^DIC ;G EXIT:Y<0
  1. K D,DIC("S"),DIC("W") I Y'=-1 S (DJDN,MCARGDA)=$P(Y,U,1) S:DIC[691.8 MCARZDN=DJDN D:DIC[691.5 ECGCH D IN^MCEO G EXIT:$D(DUOUT)!$D(DTOUT) D EN^MCARD,OUT^MCEO
  1. G EXIT
  1. ECGCH ;S:$D(^MCAR(691.5,DJDN,"A")) DJSC="MCARECGA" Q
  1. CENTER(TEXT,MGN) ;
  1. W $J("",MGN-$L(TEXT)/2),TEXT Q ""
  1. ;
  1. MCEPROC ; Get the required variables from the PROCEDURE/SUBSPECIALTY file
  1. N TEMP,OPTION,ID,ID2,ID3,ID4,ID5 S (ID,ID2)=""
  1. ;MCabPROC <=== name of an option, screen or line edit.
  1. ; a = (B => Brief), (F => Full)
  1. ; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
  1. ; PROC = the name of the procedure
  1. S (MCARGNUM,MCARGNAM,MCARP)=+$O(^MCAR(697.2,"B",MCPRO,""))
  1. S OPTION=$E($P(XQY0,U,1),3,4),TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0
  1. S (MCROUT,MCARDE)=$P(TEMP,U,8),MCFILE=+$P($P(TEMP,U,2),"MCAR(",2)
  1. S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15),MCPATFLD=$P(TEMP,U,12)
  1. S:MCESON MCESSEC=$S($D(^XUSEC(MCESKEY,DUZ)):1,1:0)
  1. S ID3=";"_$G(DIC("DR")),ID=""
  1. F S ID=+$O(^DD(MCFILE,0,"ID",ID)) Q:ID=0 D:ID'=0
  1. .S ID4=";"_ID,ID5=ID4_";",ID4=ID4_"/"
  1. .I (ID3'[ID4),(ID3'[ID5) S ID2=ID2_ID_";"
  1. S DIC("DR")=ID2_"1500////"_DUZ_";1502///NOW;1514///NOW;1502///NOW;"_$G(DIC("DR"))
  1. S DIC(0)="AQMELZ",(DIDEL,DLAYGO)=MCFILE,DIC=^DIC(MCFILE,0,"GL")
  1. I MCFILE=699 D
  1. .S MCARCODE=$S(MCPRO["GI":"G",MCPRO["NONENDO":"Z",1:"P")
  1. .S DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"
  1. S MCEPROC="MC"_OPTION_MCPRO
  1. S MCEPROC=$S(OPTION="BS":$S($P(TEMP,U,13)'="":$P(TEMP,U,13),1:MCEPROC),OPTION="BL":$S($P(TEMP,U,11)'="":$P(TEMP,U,11),1:MCEPROC),OPTION="FS":$S($P(TEMP,U,3)'="":$P(TEMP,U,3),1:MCEPROC),1:$S($P(TEMP,U,10)'="":$P(TEMP,U,10),1:MCEPROC))
  1. S MCPOSTP=$S((MCFILE=699)&(MCEPROC'["NONENDO"):"^MCARGD",1:"")
  1. Q
  1. MCPROP(MCPROP) ;
  1. N TEMP,PREFIX,CNT
  1. S PREFIX=$S($E(MCPROP,3,4)="ES":8,1:5)
  1. F CNT=PREFIX:1:$L(MCPROP) Q:$D(^MCAR(697.2,"B",$E(MCPROP,5,CNT))) ;S TEMP=$E(MCPROP,5,CNT)
  1. Q TEMP