source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCARE.m@ 861

MCARE ;WISC/RMP-EDIT ROUTINES ;1/23/03  20:45

 ;;2.3;Medicine;**35**;09/13/1996

 ; Reference IA #3746 for ^DD(file#,0,"ID") Access

 ;              #10076 for ^XUSEC

 ;              #10061 FOR ^VADPT call.

ENTER ;ENTER NEW CARDIAC PROCEDURES (SCREEN HANDLER)

 ;SELECT GLOBAL AND PROCEDURE NAME FROM PROCEDURE LOCATION FILE

 D MCEPROC

 S MCARGNUM=MCARP,DIC=^DIC(MCFILE,0,"GL")

 S DJSC=MCEPROC,USEREND=1

 S DIC(0)="AELMQZ",(DLAYGO,DIDEL)=+$P(DIC,"(",2)

 S (MCARGNAM,MCARP)=$P(^MCAR(697.2,MCARP,0),U,1)

DATE ;SELECT PROCEDURE DATE

 I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)

 ;S DR=MCPATFLD

 D DATE^MCAREH ;    guidance for the date prompt

 D ^DIC K DIC,DLAYGO

 ;CONDITIONAL ENTRY DELETE CODE HERE

 I Y'=-1 D EXISTS ;    an entry exists, so take an action

EXIT ;

 D KVAR^VADPT

 K X,Y,MCARP,DJSC,MCARPT,DIC,DJDN,DR,DIE,MCARGDA,MCARGNUM

 K DLAYGO,MCARNUM,MCARNM,DFN,DIDEL,MCFILE,MCARDE,MCSEX,MCRACE,MCFILE

 K %,%H,%X,%Y,%Y1,%Y2,D0,D1,D2,DI,DIW,DIWI,DIWT,DIWTC,DIWX,DIZ,DN,DQ

 K I,J,VA,X1,Y,Z,DJVV,%T,DIPGM,DW1,DTOUT,DUOUT,MCESS,ID2

 K DIC,DIK,DIE,DFN,DA,MCARGNUM,MCARGNAM,DR,MCX,SSN,MCARCODE,%,MCORCK

 K C,MCARAPDT,CD,MCARCDIE,MCAROLDT,XX,DIH,DIR,S,DX,DIU,DIV,DZ,MCARFIND

 K MCSPHIN,MCSTENT,MCBOUGIE,MCGTUBE,MCJTUBE,MCHEATP,MCDFLAG,MCARI

 K MCARNP,MCARTOT,DIDEL,DTOUT,DUOUT,MCESFL,EXIT,MCBACK,MCESPREV

 K MCESCUR,MCESTEMP,MCARCK,MCARDA,MCARDE,MCARP,MCESKEY,MCESON

 K MCESPED,MCESS,MCESSEC,MCFILE,MCFILE1,MCPATFLD,MCPOSTP,MCROUT

 K POP,MCPCT,MCPCTY,TEP,MCARDE,MCARP,MCESKEY,MCESON,MCESS

 Q

EXISTS ;

 S DFN=$P(Y(0),U,2) ;    patient number

 S (DJDN,MCARGDA)=$P(Y,U,1)

 I MCFILE=700 S MCRACE=$$RACECDE^MCPFTSS(DFN) K:MCRACE="" MCRACE

 I MCFILE=691.5,$D(^MCAR(MCFILE,MCARGDA,"A")) Q:'MCESON  D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q

 I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q

 ;    set certain variables based upon file selected

 I MCFILE=691.8 S MCARZDN=DJDN

 D IN^MCEO ;    order entry

 I '$D(DTOUT),'$D(DUOUT) D

 .D EN^MCARD I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK

 .I $L(MCPOSTP)>1 S X=MCPOSTP X ^%ZOSF("TEST") D:$T @MCPOSTP

 .D OUT^MCEO K DIDEL

 I MCFILE=691.8,$D(^MCAR(MCFILE,MCARGDA,0)) D EN4^MCARATVE ; atrial/ventricular studies

 D ESRC^MCESSCR(MCFILE,MCARGDA)

 I $L($G(MCRACE))>1 D

 .I $$GET1^DIQ(700,+MCARGDA_",",38,"E")="YES"&($$GET1^DIQ(700,+MCARGDA,38.5,"E")="") D

 ..N MCFDA

 ..S MCFDA(700,+MCARGDA_",",38)=""

 ..D FILE^DIE("","MCFDA")

 ..W !!?5,"*** Patient has both race values BLACK and ASIAN. ***"

 ..W !?5,"*** MUST enter a value for the RACE CORRECTIONS FOR RACE TYPE field.***"

 ..W !?5,"*** USE RACE CORRECTIONS field will be set to NULL. ***"

 ..Q

 .Q

 Q

BACK ; If the record is superseded, the user will be allow to edit the superseded record.

 S Y=MCY,DA=Y,Y(0)=MCY(0),Y(0,0)=MCY(0,0) K MCY,DTOUT,DIROUT,DUOUT,DIC

 G EXISTS

 Q

HELP G EXIT:(X=U)!(X="") W !,"ENTER A NEW PROCEDURE DATE" G DATE

EDIT Q  ; MFR 28 JAN 93 ;EDIT CARDIAC PROCEDURES BY PATIENT (SCREEN HANDLER)

 ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE

 S MCARGNUM=MCARP,MCARLK="^MCAR("_MCFILE

 S MCARLK=U_MCARLK_",""C"",+Y)"

 S DIC("S")="I $D(@(MCARLK))"

 S DIC="^MCAR(690,",DIC(0)="AEQM" D ^DIC K MCARLK I Y<0 G EXIT

 W !,MCARDE," PROCEDURES"

 ;SELECT PROCEDURE DATE

 S (MCARPT,DFN)=+Y

 D DEM^VADPT S MCARNM=VADM(1) D KVAR^VADPT

 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)

 S X=MCARNM,DIC(0)="EQ" D IX^DIC ;G EXIT:Y<0

 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

 G EXIT

ECGCH ;S:$D(^MCAR(691.5,DJDN,"A")) DJSC="MCARECGA" Q

CENTER(TEXT,MGN) ;

 W $J("",MGN-$L(TEXT)/2),TEXT Q ""

 ;

MCEPROC ; Get the required variables from the PROCEDURE/SUBSPECIALTY file

 N TEMP,OPTION,ID,ID2,ID3,ID4,ID5 S (ID,ID2)=""

 ;MCabPROC  <=== name of an option, screen or line edit.

 ; a = (B =>  Brief),  (F => Full)

 ; b = (S =>  Screen Edit), (L =>  Line Edit), (P =>  Printing)

 ; PROC = the name of the procedure

 S (MCARGNUM,MCARGNAM,MCARP)=+$O(^MCAR(697.2,"B",MCPRO,""))

 S OPTION=$E($P(XQY0,U,1),3,4),TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0

 S (MCROUT,MCARDE)=$P(TEMP,U,8),MCFILE=+$P($P(TEMP,U,2),"MCAR(",2)

 S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15),MCPATFLD=$P(TEMP,U,12)

 S:MCESON MCESSEC=$S($D(^XUSEC(MCESKEY,DUZ)):1,1:0)

 S ID3=";"_$G(DIC("DR")),ID=""

 F  S ID=+$O(^DD(MCFILE,0,"ID",ID)) Q:ID=0  D:ID'=0

 .S ID4=";"_ID,ID5=ID4_";",ID4=ID4_"/"

 .I (ID3'[ID4),(ID3'[ID5) S ID2=ID2_ID_";"

 S DIC("DR")=ID2_"1500////"_DUZ_";1502///NOW;1514///NOW;1502///NOW;"_$G(DIC("DR"))

 S DIC(0)="AQMELZ",(DIDEL,DLAYGO)=MCFILE,DIC=^DIC(MCFILE,0,"GL")

 I MCFILE=699 D

 .S MCARCODE=$S(MCPRO["GI":"G",MCPRO["NONENDO":"Z",1:"P")

 .S DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"

 S MCEPROC="MC"_OPTION_MCPRO

 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))

 S MCPOSTP=$S((MCFILE=699)&(MCEPROC'["NONENDO"):"^MCARGD",1:"")

 Q

MCPROP(MCPROP) ;

 N TEMP,PREFIX,CNT

 S PREFIX=$S($E(MCPROP,3,4)="ES":8,1:5)

 F CNT=PREFIX:1:$L(MCPROP) Q:$D(^MCAR(697.2,"B",$E(MCPROP,5,CNT)))  ;S TEMP=$E(MCPROP,5,CNT)

 Q TEMP