112 lines
5.3 KiB
Mathematica
112 lines
5.3 KiB
Mathematica
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
|