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

Last change on this file since 813 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.3 KB
Line 
1MCARE ;WISC/RMP-EDIT ROUTINES ;1/23/03 20:45
2 ;;2.3;Medicine;**35**;09/13/1996
3 ; Reference IA #3746 for ^DD(file#,0,"ID") Access
4 ; #10076 for ^XUSEC
5 ; #10061 FOR ^VADPT call.
6ENTER ;ENTER NEW CARDIAC PROCEDURES (SCREEN HANDLER)
7 ;SELECT GLOBAL AND PROCEDURE NAME FROM PROCEDURE LOCATION FILE
8 D MCEPROC
9 S MCARGNUM=MCARP,DIC=^DIC(MCFILE,0,"GL")
10 S DJSC=MCEPROC,USEREND=1
11 S DIC(0)="AELMQZ",(DLAYGO,DIDEL)=+$P(DIC,"(",2)
12 S (MCARGNAM,MCARP)=$P(^MCAR(697.2,MCARP,0),U,1)
13DATE ;SELECT PROCEDURE DATE
14 I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
15 ;S DR=MCPATFLD
16 D DATE^MCAREH ; guidance for the date prompt
17 D ^DIC K DIC,DLAYGO
18 ;CONDITIONAL ENTRY DELETE CODE HERE
19 I Y'=-1 D EXISTS ; an entry exists, so take an action
20EXIT ;
21 D KVAR^VADPT
22 K X,Y,MCARP,DJSC,MCARPT,DIC,DJDN,DR,DIE,MCARGDA,MCARGNUM
23 K DLAYGO,MCARNUM,MCARNM,DFN,DIDEL,MCFILE,MCARDE,MCSEX,MCRACE,MCFILE
24 K %,%H,%X,%Y,%Y1,%Y2,D0,D1,D2,DI,DIW,DIWI,DIWT,DIWTC,DIWX,DIZ,DN,DQ
25 K I,J,VA,X1,Y,Z,DJVV,%T,DIPGM,DW1,DTOUT,DUOUT,MCESS,ID2
26 K DIC,DIK,DIE,DFN,DA,MCARGNUM,MCARGNAM,DR,MCX,SSN,MCARCODE,%,MCORCK
27 K C,MCARAPDT,CD,MCARCDIE,MCAROLDT,XX,DIH,DIR,S,DX,DIU,DIV,DZ,MCARFIND
28 K MCSPHIN,MCSTENT,MCBOUGIE,MCGTUBE,MCJTUBE,MCHEATP,MCDFLAG,MCARI
29 K MCARNP,MCARTOT,DIDEL,DTOUT,DUOUT,MCESFL,EXIT,MCBACK,MCESPREV
30 K MCESCUR,MCESTEMP,MCARCK,MCARDA,MCARDE,MCARP,MCESKEY,MCESON
31 K MCESPED,MCESS,MCESSEC,MCFILE,MCFILE1,MCPATFLD,MCPOSTP,MCROUT
32 K POP,MCPCT,MCPCTY,TEP,MCARDE,MCARP,MCESKEY,MCESON,MCESS
33 Q
34EXISTS ;
35 S DFN=$P(Y(0),U,2) ; patient number
36 S (DJDN,MCARGDA)=$P(Y,U,1)
37 I MCFILE=700 S MCRACE=$$RACECDE^MCPFTSS(DFN) K:MCRACE="" MCRACE
38 I MCFILE=691.5,$D(^MCAR(MCFILE,MCARGDA,"A")) Q:'MCESON D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q
39 I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,.MCARGDA) G:$D(MCBACK) BACK Q
40 ; set certain variables based upon file selected
41 I MCFILE=691.8 S MCARZDN=DJDN
42 D IN^MCEO ; order entry
43 I '$D(DTOUT),'$D(DUOUT) D
44 .D EN^MCARD I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK
45 .I $L(MCPOSTP)>1 S X=MCPOSTP X ^%ZOSF("TEST") D:$T @MCPOSTP
46 .D OUT^MCEO K DIDEL
47 I MCFILE=691.8,$D(^MCAR(MCFILE,MCARGDA,0)) D EN4^MCARATVE ; atrial/ventricular studies
48 D ESRC^MCESSCR(MCFILE,MCARGDA)
49 I $L($G(MCRACE))>1 D
50 .I $$GET1^DIQ(700,+MCARGDA_",",38,"E")="YES"&($$GET1^DIQ(700,+MCARGDA,38.5,"E")="") D
51 ..N MCFDA
52 ..S MCFDA(700,+MCARGDA_",",38)=""
53 ..D FILE^DIE("","MCFDA")
54 ..W !!?5,"*** Patient has both race values BLACK and ASIAN. ***"
55 ..W !?5,"*** MUST enter a value for the RACE CORRECTIONS FOR RACE TYPE field.***"
56 ..W !?5,"*** USE RACE CORRECTIONS field will be set to NULL. ***"
57 ..Q
58 .Q
59 Q
60BACK ; If the record is superseded, the user will be allow to edit the superseded record.
61 S Y=MCY,DA=Y,Y(0)=MCY(0),Y(0,0)=MCY(0,0) K MCY,DTOUT,DIROUT,DUOUT,DIC
62 G EXISTS
63 Q
64HELP G EXIT:(X=U)!(X="") W !,"ENTER A NEW PROCEDURE DATE" G DATE
65EDIT Q ; MFR 28 JAN 93 ;EDIT CARDIAC PROCEDURES BY PATIENT (SCREEN HANDLER)
66 ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE
67 S MCARGNUM=MCARP,MCARLK="^MCAR("_MCFILE
68 S MCARLK=U_MCARLK_",""C"",+Y)"
69 S DIC("S")="I $D(@(MCARLK))"
70 S DIC="^MCAR(690,",DIC(0)="AEQM" D ^DIC K MCARLK I Y<0 G EXIT
71 W !,MCARDE," PROCEDURES"
72 ;SELECT PROCEDURE DATE
73 S (MCARPT,DFN)=+Y
74 D DEM^VADPT S MCARNM=VADM(1) D KVAR^VADPT
75 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)
76 S X=MCARNM,DIC(0)="EQ" D IX^DIC ;G EXIT:Y<0
77 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
78 G EXIT
79ECGCH ;S:$D(^MCAR(691.5,DJDN,"A")) DJSC="MCARECGA" Q
80CENTER(TEXT,MGN) ;
81 W $J("",MGN-$L(TEXT)/2),TEXT Q ""
82 ;
83MCEPROC ; Get the required variables from the PROCEDURE/SUBSPECIALTY file
84 N TEMP,OPTION,ID,ID2,ID3,ID4,ID5 S (ID,ID2)=""
85 ;MCabPROC <=== name of an option, screen or line edit.
86 ; a = (B => Brief), (F => Full)
87 ; b = (S => Screen Edit), (L => Line Edit), (P => Printing)
88 ; PROC = the name of the procedure
89 S (MCARGNUM,MCARGNAM,MCARP)=+$O(^MCAR(697.2,"B",MCPRO,""))
90 S OPTION=$E($P(XQY0,U,1),3,4),TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0
91 S (MCROUT,MCARDE)=$P(TEMP,U,8),MCFILE=+$P($P(TEMP,U,2),"MCAR(",2)
92 S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15),MCPATFLD=$P(TEMP,U,12)
93 S:MCESON MCESSEC=$S($D(^XUSEC(MCESKEY,DUZ)):1,1:0)
94 S ID3=";"_$G(DIC("DR")),ID=""
95 F S ID=+$O(^DD(MCFILE,0,"ID",ID)) Q:ID=0 D:ID'=0
96 .S ID4=";"_ID,ID5=ID4_";",ID4=ID4_"/"
97 .I (ID3'[ID4),(ID3'[ID5) S ID2=ID2_ID_";"
98 S DIC("DR")=ID2_"1500////"_DUZ_";1502///NOW;1514///NOW;1502///NOW;"_$G(DIC("DR"))
99 S DIC(0)="AQMELZ",(DIDEL,DLAYGO)=MCFILE,DIC=^DIC(MCFILE,0,"GL")
100 I MCFILE=699 D
101 .S MCARCODE=$S(MCPRO["GI":"G",MCPRO["NONENDO":"Z",1:"P")
102 .S DIC("S")="I $D(^MCAR(697.2,""D"",MCARCODE,+$P(^MCAR(699,+Y,0),U,12)))"
103 S MCEPROC="MC"_OPTION_MCPRO
104 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))
105 S MCPOSTP=$S((MCFILE=699)&(MCEPROC'["NONENDO"):"^MCARGD",1:"")
106 Q
107MCPROP(MCPROP) ;
108 N TEMP,PREFIX,CNT
109 S PREFIX=$S($E(MCPROP,3,4)="ES":8,1:5)
110 F CNT=PREFIX:1:$L(MCPROP) Q:$D(^MCAR(697.2,"B",$E(MCPROP,5,CNT))) ;S TEMP=$E(MCPROP,5,CNT)
111 Q TEMP
Note: See TracBrowser for help on using the repository browser.