source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCARGE.m@ 1766

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

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1MCARGE ;WISC/TJK-GI ENTER/EDIT ;5/8/96 14:29
2 ;;2.3;Medicine;;09/13/1996
3START ;EDIT ENDSCOPY
4 K EXIT,MCDEMO,MCESFL S MCESFL=1 D PREEDT
5 I '$D(MCFILE)!'$D(MCARGDA) D EXIT Q
6 I '$D(^MCAR(MCFILE,MCARGDA,0)),$D(MCBACK) D BACKSS^MCESEDT K MCBACK
7 K:'$D(^MCAR(MCFILE,MCARGDA,0)) MCESFL
8 I $D(MCESFL),MCESON D:MCESFL=0 ESRC^MCESSCR(MCFILE,MCARGDA)
9 D EXIT
10 Q
11PREEDT ; Allow editing of demo and allergy
12 S MCDEMO=1 D DPT Q:$D(EXIT)
13 I MCARCODE="G"!(MCARCODE="P") F D DEMO Q:'$D(MCDEMO) D:$D(MCDEMO) EDITDEMO
14 Q:$D(EXIT) D EDIT
15 Q
16EDIT ;Lets edit Endoscopy
17 K DR,DIC,DIE S (DIE,DIC)="^MCAR(699,",DA=MCARGDA,MCFILE=699
18 G EDIT1:MCARGNAM="NON-ENDO",EDIT1:MCARCODE'="G" D SETVAR
19EDIT1 ; Lets edit Non-Endo
20 D IN^MCEO I $D(DTOUT)!$D(DUOUT) S EXIT=1 Q
21 S DR="["_MCEPROC_"]" D ^DIE
22 I $D(DA) D ^MCARGD,OUT^MCEO
23 Q
24EXIT ;Lets leave
25 D EXIT^MCARE
26 Q
27SETVAR ;Set Pulmonary variables
28 S MCSTENT=$O(^MCAR(699.6,"B","INSERTION OF STENT",0)),MCSPHIN=$O(^MCAR(699.6,"B","SPHINCTEROTOMY",0))
29 S MCBOUGIE=$O(^MCAR(699.6,"B","DILATION BY SAVARY BOUGIE",0)),MCGTUBE=$O(^MCAR(699.6,"B","GASTROSTOMY TUBE INSERTED",0)),MCJTUBE=$O(^MCAR(699.6,"B","JEJUNOSTOMY TUBE INSERTED",0))
30 S MCHEATP=$O(^MCAR(699.6,"B","HEATER PROBE COAGULATION",0))
31 Q
32CONSULT K DIC S MCARGNUM=$O(^MCAR(697.2,"B","CONSULT",0)),DIC("DR")=".01;.02;2////1;.05////"_MCARGNUM
33 S DIC="^MCAR(699.5,",DLAYGO=699.5,DIC(0)="AEQLMZ",DIC("A")="ENTER DATE/TIME OF CONSULT: ",DIC("S")="I $P(^MCAR(699.5,+Y,0),U,3)" D ^DIC K DIC("S"),DIC("A"),DLAYGO I $D(MCDFLAG),Y<0 Q
34 G EXIT:Y<0
35 I '$P(Y(0),U,2)!'$P(Y(0),U,3) S DIK="^MCAR(699.5,",DA=+Y D ^DIK Q:$D(MCDFLAG) G EXIT
36 S DFN=$P(Y(0),U,2),DIE=DIC,(MCARGDA,DA)=+Y Q:$D(MCDFLAG)
37 S MCFILE=699.5 D ORDER^MCARGEO G EXIT:$D(DTOUT)!$D(DUOUT) S DR=$S($G(MCBS)=1:"[MCCONSULTBR]",1:"[MCCONSULT]") D ^DIE,ORDER1^MCARGEO,QTASK^MCPARAM G EXIT
38DPT ;ALSO CALLED FROM MCARGES
39 S MCESFL=0 D MCEPROC^MCARE S MCARGNUM=MCARP
40 D DATE^MCAREH
41 S DIC="^MCAR(699,",DIC("A")="Enter Date/Time of Procedure: ",DIC(0)="AEQLMZ"
42 S DIC("S")="S MCARCK=$P(^MCAR(699,+Y,0),U,12) I MCARCK'="""",$D(^MCAR(697.2,""D"",MCARCODE,MCARCK))",(DLAYGO,MCFILE)=699
43 I MCESON S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
44 D ^DIC K DIC,DLAYGO,MCBACK S MCARDA=Y
45 I Y<0 S EXIT=0 Q
46 S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
47 I MCESON,("125"'[$$ESTONUM^MCESSCR(MCFILE,MCARGDA)) D ESRC^MCESSCR(MCFILE,MCARGDA) I '$D(MCBACK) S X=U,MCESFL=1,EXIT=1 Q ;RMP CHANGED () EXPRESSION FROM >2
48 I $D(MCBACK) D BACK S X=U Q
49 I $D(DTOUT),('$P(Y(0),U,2)!'$P(Y(0),U,12)) S DIK="^MCAR(699,",DA=+Y D ^DIK S EXIT=1 Q
50 Q
51DEMO ;Lets display the demo information ask if they want to edit
52 ; -------------------
53 ; SSN = External Format of the patients SSN
54 ; -------------------
55 D DEM^VADPT S SSN=$P(VADM(2),U,2) D HIST Q
56HIST ;Lets look at the history
57 W !!,?26,"PERSONAL HISTORY INFORMATION",!,?5,VADM(1),?50,"SSN: ",SSN,!
58 S DIC="^MCAR(690,",DA=DFN G HIST1:MCARCODE="P"
59 S DR="GI" D EN^DIQ K DIC,DR G HIST2
60HIST1 ;Lets look at some more history
61 K ^UTILITY("DIQ1",$J) S DIC="^MCAR(690,",DA=DFN,DR="3:6" D EN^DIQ1 G HIST2:'$D(^UTILITY("DIQ1",$J))
62 W !,?2,"History of Bleeding Disorder: ",^UTILITY("DIQ1",$J,690,DA,3),?40,"Valvular Heart Disease: ",^(4),!,?2,"Glaucoma: ",^(5),!,?2,"History Comments: ",^(6) K ^UTILITY("DIQ1",$J) W !
63HIST2 ;Lets display allergy and ask the question
64 D ^MCARGEA ; display allergy information
65 S DIR(0)="Y",DIR("A")="Do you wish to edit the Personal History Information"
66 S DIR("?")="Answer 'YES' or 'NO'",DIR("B")="NO" D ^DIR K DIR
67 I $D(DUOUT)!$D(DIROUT) S EXIT=1 K MCDEMO Q
68 K:Y=0 MCDEMO Q
69EDITDEMO ;lets edit the demo and allergy using the line editor
70 S (DIE,DIC)="^MCAR(690,",DA=DFN,DR="[MCARGIED]" D ^DIE
71 I $D(^DIC(120.8)) N VADM D EN2^GMRAPEM0 Q
72 G HIST
73 ;
74HELP ;DISPLAY CHOOSABLE ANATOMY LOCATIONS-CALLED BY FINDINGS,ATRIAL STUDY,VENTRICULAR STUDY FILES
75 S (DZ,MCDONE)="" W !!,"The valid Anatomy locations are: ",!
76 F I=0:0 S I=$O(^MCAR(697,"C",MCARGNUM,I)) Q:'I W:$X>50 ! W $E($P(^MCAR(697,I,0),U)_" ",1,40) I $D(DJDN),$Y>20,$X>50 W ! R "'^' TO STOP: ",%Y:DTIME X:%Y'?1"^" DJCP Q:%Y?1"^"
77 R:$D(DJDN) !,"* END * Press return to continue: ",%Y:DTIME Q
78DPTNON ;
79 S DIC="^MCAR(699,",DIC("A")="Enter Date/Time of Non-Endoscopic Procedure: ",DIC(0)="AEQLMZ"
80 S DIC("S")="I $P($G(^MCAR(697.2,+$P(^MCAR(699,+Y,0),U,12),0)),U)=""NON-ENDO"""_MCTEST,DLAYGO=699
81 S DIC("S")=$$PREEDIT^MCESSCR(MCFILE)
82 S DIC("DR")=".02;1///NON-ENDO"
83 D ^DIC
84 K DIC,DLAYGO
85 I $D(MCDFLAG),Y<0 S X=U Q
86 G EXIT:Y<0
87 I $D(DTOUT),('$P(Y(0),U,2)!'$P(Y(0),U,12)) S DIK="^MCAR(699,",DA=+Y D ^DIK Q:$D(MCDFLG) G EXIT
88 S DFN=$P(Y(0),U,2),MCARGDA=+Y,MCARGNUM=$P(Y(0),U,12),MCARGNAM=$P(^MCAR(697.2,MCARGNUM,0),U)
89 ; -------------------
90 ; SSN = External Format of the patients SSN
91 ; -------------------
92 D DEM^VADPT S SSN=$P(VADM(2),U,2)
93 G HIST
94BACK ;
95 S Y=MCY,Y(0)=MCY(0),Y(0,0)=MCY(0,0),MCARGDA=+Y K EXIT,MCY,DTOUT,DIROUT,DUOUT,MCDFLAG
96 Q
Note: See TracBrowser for help on using the repository browser.