source: FOIAVistA/tag/r/MEDICINE-MC/MCARP.m@ 876

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1MCARP ;WISC/TJK,WAA-PRINT ROUTINES ;12/15/97 14:54
2 ;;2.3;Medicine;**6,14,15,18,27,33,35,39**;09/13/1996
3 ; Reference IA #2432 for Hospital Location File #44 FM Lookup
4 ; #1576 for DIVISION file 40.8 lookup
5 ; #10035 for Patient File (#2) Direct Global Reads
6 ; #10061 for ^VADPT call.
7 ;
8CATH ;
9 S DIC="^MCAR(691.1,",MCARZ="CATHETERIZATION REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"CATHB",1:"CATH1") G LOOK
10ECHO S DIC="^MCAR(691,",MCARZ="ECHO REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ECHOB",1:"ECHO1") G LOOK
11ECG S DIC="^MCAR(691.5,",MCARZ="ECG REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ECGB",1:"ECG1") G LOOK
12EP S DIC="^MCAR(691.8,",MCARZ="EP REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"EPB",1:"EP1") G LOOK
13HOLTER S DIC="^MCAR(691.6,",MCARZ="HOLTER REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"HOLTERB",1:"HOLTER1") G LOOK
14RHFULL S DIC="^MCAR(701,",MCARZ="RHEUMATOLOGY REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"RHB",1:"RHFULL1") G LOOK
15ETT S DIC="^MCAR(691.7,",MCARZ="ETT REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ETTB",1:"ETT1")
16LOOK ;
17 D MCPPROC
18 I '$D(MCARPPS) D LOOK2,^DIC G:Y<0 EXIT S (MCARGDA,DA)=+Y
19 I $G(MCESON),$D(^MCAR(MCFILE,MCARGDA,"ES")) D STATUS^MCESPRT(MCFILE,MCARGDA)
20 I $D(ORHFS) U IO G PRINT ;dcm/slc added for CPRS
21DEVQUE ; Device Control and Queuing Control
22 K IO("Q") S %ZIS="MQ" D ^%ZIS I POP S MCOUT="" G EXIT
23 I $D(IO("Q")) S (ZTSAVE("DIC"),ZTSAVE("MC*"))="",ZTRTN="PRINT^MCARP",ZTDESC=MCARZ D ^%ZTLOAD K ZTSK G EXIT
24 U IO
25PRINT ; Print Report
26 ;I DIC="^MCAR(699," D ;MC*2.3*33
27 ;.N MCHLD,MCHLD2 ;MC*2.3*33
28 ;.S MCHLD=$$GET1^DIQ(699,MCARGDA,1,"I") ;MC*2.3*33
29 ;.S MCHLD2=$$GET1^DIQ(697.2,MCARGNUM,1,"I") ;MC*2.3*33
30 ;.I MCHLD'=MCHLD2 S MCARGRTN="PARAC" ;MC*2.3*33
31 ;.Q ;MC*2.3*33
32 K DXS,DIOT(2),^UTILITY($J),MCOUT S (D0,DA)=MCARGDA,PG=0
33 S DFN=$P(^MCAR(+$P(DIC,"(",2),MCARGDA,0),U,2),MCARGDT=$P(^(0),U,1) S:DIC[699 MCARGNUM=$P(^(0),U,$S(DIC[699.5:6,1:12))
34RHPRT ;
35 D INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
36 S ^UTILITY($J,1)="S MCY="""" I $Y>IOSL-3 R:$E(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"
37 D HEAD,CALLTEM
38 I '$D(MCOUT) D:$G(MCESON) FOOTER^MCESPRT(MCFILE,MCARGDA)
39 S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
40 G EXIT
41CALLTEM ;
42 N MCFILE D @MCARGRTN Q
43EXIT ;
44 D EXIT^MCARP1 Q
45LOOK2 ;
46 S DIC(0)="AEMQ",DIC("A")="Enter patient name or the date & time: "
47 I MCESON S DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
48 Q
49CATH1 D ^MCAROC1 K DXS Q:$D(MCOUT) D ^MCAROC2 K DXS Q:$D(MCOUT) D ^MCAROC3 K DXS Q:$D(MCOUT) D ^MCAROC4 Q
50CATHB D ^MCOBC1 Q
51ECHO1 D ^MCRPEC K DXS Q:$D(MCOUT) Q
52ECHOB D ^MCOBK Q
53ECG1 D ^MCAROK Q
54ECGB D ^MCOBE1 Q
55EPB D ^MCOBEP Q
56EP1 D ^MCAROEP G EPEND:$D(MCOUT)
57 G VT:'$D(^MCAR(691.9,"C",MCARGDA))
58 S MCY=""
59 I $Y>IOSL-3 R:$E(IOST,1,2)="C-" !!,"Press return to continue, '^' to escape: ",MCY:DTIME S:'$T MCY=U S:$E(MCY)=U MCOUT=1 G:$G(MCOUT)=1 EPEND
60 F D0=0:0 S D0=$O(^MCAR(691.9,"C",MCARGDA,D0)) Q:D0="" K DXS D HEAD,^MCAROAT G EPEND:$D(MCOUT)
61VT Q:'$D(^MCAR(692,"C",MCARGDA))
62 I $Y>IOSL-3 R:$E(IOST,1,2)="C-" !!,"Press return to continue, '^' to escape: ",MCY:DTIME S:'$T MCY=U S:$E(MCY)=U MCOUT=1 G:$G(MCOUT)=1 EPEND
63 F D0=0:0 S D0=$O(^MCAR(692,"C",MCARGDA,D0)) Q:D0="" K DXS D HEAD,^MCAROV Q:$D(MCOUT)
64EPEND Q
65ETT1 D ^MCAROT Q
66ETTB D ^MCOBT Q
67HOLTER1 D ^MCAROH1 K DXS Q:$D(MCOUT) D ^MCAROH2 Q
68HOLTERB D ^MCOBH1 Q
69GENERIC D ^MCAROGE Q
70GENERICB D ^MCOBGEN Q
71GI ;I $D(^DIC(120.8)) D ^MCAROGM I 1 ; new allergy info
72 D ^MCAROG
73 K DXS
74 D:'$D(MCOUT) ^MCAROGA
75 Q
76PARAC D ^MCPARC Q ; MC*2.3*33
77GIB D ^MCOBGA Q
78PULM D ^MCAROP K DXS Q:$D(MCOUT) D ^MCAROPE Q
79PULMB D ^MCOBPE Q
80NONENDO D ^MCAROGN Q
81NONENDOB D ^MCOBGN Q
82CONSULT D ^MCAROGC Q
83CONSULTB D ^MCOBGC Q
84GENIMP D ^MCAROPG Q
85GENIMPB D ^MCOBPG Q
86ALEAD D ^MCAROPA Q
87ALEADB D ^MCOBPA Q
88VLEAD D ^MCAROPV Q
89VLEADB D ^MCOBPV Q
90SURV D ^MCAROPS Q
91SURVB D ^MCOBPS Q
92RHFULL1 ;
93 N MCARRC,MCHOLD D DEM^VADPT S (MCARRC,MCHOLD)=$P(VADM(8),U,2),MCARRC=$$ETHN^MCPFTP1(MCHOLD,.VADM) D KVAR^VADPT
94 I +$G(MCRH)=0 D RHFULL2 Q
95 S MCFILE=701,V=MCRH,MCRHR="^MCAROR"_$S(V=1:"A",V=2:"B",V=3:"N",V=4:"L",V=6:"Q",V=7:"H",V=8:"P",V=9:"D",1:"RHFULL2^MCARP") D @MCRHR K DXS Q:$D(MCOUT) D:V=8 ^MCARORE K DXS Q:$D(MCOUT) D:MCRH=1 DISP^MCMAG Q
96RHFULL2 ;
97 F RH="A","B","N","L","Q","H","P","E","D" Q:$D(MCOUT) D
98 .S MCFILE=701,MCRHR="^MCAROR"_RH D @MCRHR K DXS Q:$D(MCOUT)
99 .I RH="A" D DISP^MCMAG K DXS
100 Q
101RHB D ^MCOBRH K DXS Q:$D(MCOUT) D ^MCOBRHA Q
102DTIME ; Setup Date/Time
103 S MCT=$P(X,".",2),X=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")_" "_$S(MCT:$E(MCT,1,2)_$E("00",0,2-$L($E(MCT,1,2)))_":"_$E(MCT,3,4)_$E("00",0,2-$L($E(MCT,3,4))),1:"")
104 K MCT Q
105HEAD ;
106 S HOSP=$P($G(^DPT(DFN,.1)),U)
107 S:HOSP'="" HOSP=$$FIND1^DIC(44,,"X",HOSP)
108 S:HOSP'<1 HOSP=$$GET1^DIQ(44,HOSP,3.5,"I")
109 S:HOSP'="" HOSP=$P($G(^DG(40.8,HOSP,0)),U)
110 S PG=PG+1 W:PG>1 @IOF I '+$G(MCFLG) D
111 . W !!,"Pg. "_PG,?30,HOSP,?79-$L(MCARDTM),MCARDTM
112 . I (PG>1),($E(IOST,1,2)="C-") W ! Q
113 . I MCARZ'["NON-" D
114 . . I $G(MCARGRTN)="PARAC" S MCARZ="NON-"_MCARZ
115 . . Q
116 . W !,$$HEDSTAR("CONFIDENTIAL "_MCARZ,77) ; MC*2.3*33
117 . W !,MCARGNM_" "_SSN_" " W ?39-($L(MCARWARD_" "_MCARRB)\2),MCARWARD_" "_MCARRB,?79-$L(" DOB: "_MCARDOB)," DOB: "_MCARDOB
118 . Q
119 I +$G(MCFLG) W !,$$HEDSTAR(MCARZ,77)
120 W !,?39-($L("PROCEDURE DATE/TIME: "_MCARGDT2)\2),"PROCEDURE DATE/TIME: ",MCARGDT2
121 N FFF S $P(FFF,"- ",40)="- " W !,FFF,!
122 Q
123HEDSTAR(X,X1) ; surround text string X with asterisks to length X1
124 N Y1
125 S (TY,Y1)="",$P(Y1," ",X1-$L(X)\2-1)=" ",TY=Y1_" "_X_" "
126 F I=$L(TY):1:X1 S TY=TY_" "
127 Q TY
128MCPPROC ; Get require variables
129 D MCPPROC^MCARP1 Q
130XTRCT(FULL) ;Extrinsic Function use to determine Full reporting or brief
131 Q $S($E($P(FULL,U),3)="B":0,1:1)
132MCPROP(MCPROP) ; Medicine Procedure file entry validator
133 N TEMP,PREFIX,CNT
134 S PREFIX=$S($E(MCPROP,3,4)="ES":7,1:4),TEMP=""
135 F CNT=PREFIX+2:1:$L(MCPROP) I $D(^MCAR(697.2,"B",$E(MCPROP,PREFIX+1,CNT))) S TEMP=$E(MCPROP,PREFIX+1,CNT) Q
136 Q TEMP
Note: See TracBrowser for help on using the repository browser.