source: FOIAVistA/trunk/r/MEDICINE-MC/MCMAGDSP.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1MCMAGDSP ;WISC/RMP-IMAGING INTERFACE ;5/8/97 08:21
2 ;;2.3;Medicine;**6**;09/13/1996
3 ;
4REPRT(MCARGDA,FILE) ;
5 N D,D0,D1,DA,DALL,DC,DCL,DE,DFN,DI,DIC,DICMX,DIEDT,DIL
6 N DIOBEG,DIOEND,DIP,DIPZ,DIQ,DISTP,DIW,DIWF,DIWL,DIWR,DIWT,DJ,DK,DL,DN
7 N DPP,DPQ,DQI,DSC,DU,DV,DXS,DY,FLDS,I,J,X,Y,Z,%,%H,%I
8 N MCAR,MCAR1,MCARDE,MCARDOB,MCARDTM,MCARGDT,MCARGDT2,MCARGNAM
9 N MCARGNM,MCARGNUM,MCARGRTN,MCARHDR,MCARP,MCARRB,MCARWARD,MCARZ
10 N MCESKEY,MCESON,MCESS,MCESSEC,MCFILE,MCFILE1,MCFILET,MCOUNT,MCOUT
11 N MCPATFLD,MCPRO,MCPRTRTN,MCROUT,MCSUP
12 N NAME,PG,PGM,POP,RDATE,RH,SSN,VA,TY
13 ;Establish Proccedure Subspecialty file entry
14 ;to provide access to paramenters
15 S MCPRO=$S(FILE=691:"ECHO",FILE=691.1:"CATH",FILE=691.5:"ECG",FILE=701:"RHEUM",1:"")
16 S:FILE=694 MCPRO=$P(^MCAR(697.2,$P(^MCAR(FILE,MCARGDA,0),U,3),0),U)
17 S:FILE=699 MCPRO=$P(^MCAR(697.2,$P(^MCAR(FILE,MCARGDA,0),U,12),0),U)
18 S:FILE=699.5 MCPRO=$P(^MCAR(697.2,$P(^MCAR(FILE,MCARGDA,0),U,6),0),U)
19 Q:MCPRO=""
20 D PROC ;Set up parameters
21 D:$G(MCESON) STATUS^MCESPRT(FILE,MCARGDA)
22 D @MCPRTRTN
23 K ^UTILITY($J)
24 Q
25RHFULL ;
26 S MCARGRTN="^MCARORA" D PRINT K DXS Q:$D(MCOUT)
27 F RH="B","N","L","Q","H","P","E","D" Q:$D(MCOUT) D
28 .S MCARGRTN="^MCAROR"_RH D CALLTEM K DXS Q:$D(MCOUT)
29 D REND
30 Q
31CATH ;
32 S MCARGRTN="CATH1" D PRINT,REND Q
33ECHO ;
34 S MCARGRTN="ECHO1" D PRINT,REND Q
35ECG ;
36 S MCARGRTN="ECG1" D PRINT,REND Q
37CATH1 ;
38 D ^MCAROC1 K DXS Q:$D(MCOUT)
39 D ^MCAROC2 K DXS Q:$D(MCOUT)
40 D ^MCAROC3 K DXS Q:$D(MCOUT)
41 D ^MCAROC4
42 Q
43ECHO1 ;
44 ;D ^MCAROE1 K DXS Q:$D(MCOUT)
45 ;D ^MCAROE2,REND Q
46 D ^MCRPEC K DXS Q:$D(MCOUT) D REND Q
47ECG1 ;
48 D ^MCAROK Q
49GENERIC ;
50 S MCARGRTN="^MCAROGE" D PRINT,REND Q
51EN1 ;CONSULTS
52 S MCARGRTN="^MCAROGC" D PRINT,REND Q
53GENDO ;
54 S MCARGRTN=$S($D(^DIC(120.8)):"^MCAROGM",1:"^MCAROG")
55 D PRINT K DXS Q:$D(MCOUT)
56 S MCARGRTN="^MCAROGA" D PRINT,REND Q
57PENDO ;
58 S MCARGRTN="^MCAROP" D PRINT K DXS Q:$D(MCOUT)
59 S MCARGRTN="^MCAROPE" D PRINT,REND Q
60NENDO ;
61 S MCARGRTN="^MCAROGN" D PRINT,REND Q
62HEM ;
63 S (D0,DA)=MCARGDA
64 N MCFILE S MCFILE=FILE
65 D HEM^MCARHP Q
66PRINT ; Print Report
67 S (D0,DA)=MCARGDA,DIC=FILE,PG=0
68 K DXS,DIOT(2),^UTILITY($J),MCOUT
69 S DFN=$P(^MCAR(FILE,MCARGDA,0),U,2),MCARGDT=$P(^(0),U,1)
70 D INIT^MCARP1(MCARZ,MCARGDT,FILE)
71 S ^UTILITY($J,1)="S MCY="""" I $Y>(IOSL-4) R:$E($G(IOST),1,2)=""C-"" !!,""Press return to continue, '^' to escape: "",MCY:DTIME S:'$T MCY=U S:MCY=U DN=0,MCOUT=1 D:DN HEAD^MCARP K MCY"
72 D HEAD^MCARP,CALLTEM
73 I '$D(MCOUT) D:$G(MCESON) FOOTER^MCESPRT(FILE,MCARGDA)
74 Q
75CALLTEM ;
76 D @MCARGRTN Q
77PROC ;
78 N TEMP S MCARP=""
79 S (MCARP,MCARGNUM,MCARGNAM)=+$O(^MCAR(697.2,"B",MCPRO,MCARP))
80 S TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0
81 S MCSUP=+$P(TEMP,U,16),(MCROUT,MCARDE)=$P(TEMP,U,8)
82 S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15)
83 S MCARGNAM=$P(TEMP,U),MCPATFLD=$P(TEMP,U,12)
84 S (MCOUNT,MCESSEC)=0
85 ;I MCESON S:$D(^XUSEC(MCESKEY,DUZ)) MCESSEC=1
86 I MCESON S MCESSEC=$S(MCESKEY="":1,1:$D(^XUSEC(MCESKEY,DUZ)))
87 S MCPRTRTN=$P(TEMP,U,5)
88 S:FILE=699 MCPRTRTN=$S($P(TEMP,U,7)["GI":"GENDO",$P(TEMP,U,7)["PULM":"PENDO",1:"NENDO")
89 S:FILE=694 MCPRTRTN="HEM"
90 S MCARZ=$P(^MCAR(697.2,MCARGNUM,0),U,8)_" REPORT"
91 Q
92REND ;
93 ; NOTE: '$D(XWBOS) to be patched when RPC Broker has an official method
94 I '$D(XWBOS),'$D(MCOUT),$G(Y)'<0 R !!," * END * Press return to continue: ",X:DTIME
95 Q
Note: See TracBrowser for help on using the repository browser.