source: FOIAVistA/trunk/r/MEDICINE-MC/MCARE.m@ 1274

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