VistA-WorldVistAEHR/r/MEDICINE-MC/MCARP.m

137 lines
5.8 KiB
Mathematica
Raw Normal View History

2009-11-29 13:37:14 -05:00
MCARP ;WISC/TJK,WAA-PRINT ROUTINES ;12/15/97 14:54
;;2.3;Medicine;**6,14,15,18,27,33,35,39**;09/13/1996
; Reference IA #2432 for Hospital Location File #44 FM Lookup
; #1576 for DIVISION file 40.8 lookup
; #10035 for Patient File (#2) Direct Global Reads
; #10061 for ^VADPT call.
;
CATH ;
S DIC="^MCAR(691.1,",MCARZ="CATHETERIZATION REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"CATHB",1:"CATH1") G LOOK
ECHO S DIC="^MCAR(691,",MCARZ="ECHO REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ECHOB",1:"ECHO1") G LOOK
ECG S DIC="^MCAR(691.5,",MCARZ="ECG REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ECGB",1:"ECG1") G LOOK
EP S DIC="^MCAR(691.8,",MCARZ="EP REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"EPB",1:"EP1") G LOOK
HOLTER S DIC="^MCAR(691.6,",MCARZ="HOLTER REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"HOLTERB",1:"HOLTER1") G LOOK
RHFULL S DIC="^MCAR(701,",MCARZ="RHEUMATOLOGY REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"RHB",1:"RHFULL1") G LOOK
ETT S DIC="^MCAR(691.7,",MCARZ="ETT REPORT",MCARGRTN=$S('$$XTRCT(XQY0):"ETTB",1:"ETT1")
LOOK ;
D MCPPROC
I '$D(MCARPPS) D LOOK2,^DIC G:Y<0 EXIT S (MCARGDA,DA)=+Y
I $G(MCESON),$D(^MCAR(MCFILE,MCARGDA,"ES")) D STATUS^MCESPRT(MCFILE,MCARGDA)
I $D(ORHFS) U IO G PRINT ;dcm/slc added for CPRS
DEVQUE ; Device Control and Queuing Control
K IO("Q") S %ZIS="MQ" D ^%ZIS I POP S MCOUT="" G EXIT
I $D(IO("Q")) S (ZTSAVE("DIC"),ZTSAVE("MC*"))="",ZTRTN="PRINT^MCARP",ZTDESC=MCARZ D ^%ZTLOAD K ZTSK G EXIT
U IO
PRINT ; Print Report
;I DIC="^MCAR(699," D ;MC*2.3*33
;.N MCHLD,MCHLD2 ;MC*2.3*33
;.S MCHLD=$$GET1^DIQ(699,MCARGDA,1,"I") ;MC*2.3*33
;.S MCHLD2=$$GET1^DIQ(697.2,MCARGNUM,1,"I") ;MC*2.3*33
;.I MCHLD'=MCHLD2 S MCARGRTN="PARAC" ;MC*2.3*33
;.Q ;MC*2.3*33
K DXS,DIOT(2),^UTILITY($J),MCOUT S (D0,DA)=MCARGDA,PG=0
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))
RHPRT ;
D INIT^MCARP1(MCARZ,MCARGDT,MCFILE)
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"
D HEAD,CALLTEM
I '$D(MCOUT) D:$G(MCESON) FOOTER^MCESPRT(MCFILE,MCARGDA)
S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
G EXIT
CALLTEM ;
N MCFILE D @MCARGRTN Q
EXIT ;
D EXIT^MCARP1 Q
LOOK2 ;
S DIC(0)="AEMQ",DIC("A")="Enter patient name or the date & time: "
I MCESON S DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
Q
CATH1 D ^MCAROC1 K DXS Q:$D(MCOUT) D ^MCAROC2 K DXS Q:$D(MCOUT) D ^MCAROC3 K DXS Q:$D(MCOUT) D ^MCAROC4 Q
CATHB D ^MCOBC1 Q
ECHO1 D ^MCRPEC K DXS Q:$D(MCOUT) Q
ECHOB D ^MCOBK Q
ECG1 D ^MCAROK Q
ECGB D ^MCOBE1 Q
EPB D ^MCOBEP Q
EP1 D ^MCAROEP G EPEND:$D(MCOUT)
G VT:'$D(^MCAR(691.9,"C",MCARGDA))
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:$E(MCY)=U MCOUT=1 G:$G(MCOUT)=1 EPEND
F D0=0:0 S D0=$O(^MCAR(691.9,"C",MCARGDA,D0)) Q:D0="" K DXS D HEAD,^MCAROAT G EPEND:$D(MCOUT)
VT Q:'$D(^MCAR(692,"C",MCARGDA))
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
F D0=0:0 S D0=$O(^MCAR(692,"C",MCARGDA,D0)) Q:D0="" K DXS D HEAD,^MCAROV Q:$D(MCOUT)
EPEND Q
ETT1 D ^MCAROT Q
ETTB D ^MCOBT Q
HOLTER1 D ^MCAROH1 K DXS Q:$D(MCOUT) D ^MCAROH2 Q
HOLTERB D ^MCOBH1 Q
GENERIC D ^MCAROGE Q
GENERICB D ^MCOBGEN Q
GI ;I $D(^DIC(120.8)) D ^MCAROGM I 1 ; new allergy info
D ^MCAROG
K DXS
D:'$D(MCOUT) ^MCAROGA
Q
PARAC D ^MCPARC Q ; MC*2.3*33
GIB D ^MCOBGA Q
PULM D ^MCAROP K DXS Q:$D(MCOUT) D ^MCAROPE Q
PULMB D ^MCOBPE Q
NONENDO D ^MCAROGN Q
NONENDOB D ^MCOBGN Q
CONSULT D ^MCAROGC Q
CONSULTB D ^MCOBGC Q
GENIMP D ^MCAROPG Q
GENIMPB D ^MCOBPG Q
ALEAD D ^MCAROPA Q
ALEADB D ^MCOBPA Q
VLEAD D ^MCAROPV Q
VLEADB D ^MCOBPV Q
SURV D ^MCAROPS Q
SURVB D ^MCOBPS Q
RHFULL1 ;
N MCARRC,MCHOLD D DEM^VADPT S (MCARRC,MCHOLD)=$P(VADM(8),U,2),MCARRC=$$ETHN^MCPFTP1(MCHOLD,.VADM) D KVAR^VADPT
I +$G(MCRH)=0 D RHFULL2 Q
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
RHFULL2 ;
F RH="A","B","N","L","Q","H","P","E","D" Q:$D(MCOUT) D
.S MCFILE=701,MCRHR="^MCAROR"_RH D @MCRHR K DXS Q:$D(MCOUT)
.I RH="A" D DISP^MCMAG K DXS
Q
RHB D ^MCOBRH K DXS Q:$D(MCOUT) D ^MCOBRHA Q
DTIME ; Setup Date/Time
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:"")
K MCT Q
HEAD ;
S HOSP=$P($G(^DPT(DFN,.1)),U)
S:HOSP'="" HOSP=$$FIND1^DIC(44,,"X",HOSP)
S:HOSP'<1 HOSP=$$GET1^DIQ(44,HOSP,3.5,"I")
S:HOSP'="" HOSP=$P($G(^DG(40.8,HOSP,0)),U)
S PG=PG+1 W:PG>1 @IOF I '+$G(MCFLG) D
. W !!,"Pg. "_PG,?30,HOSP,?79-$L(MCARDTM),MCARDTM
. I (PG>1),($E(IOST,1,2)="C-") W ! Q
. I MCARZ'["NON-" D
. . I $G(MCARGRTN)="PARAC" S MCARZ="NON-"_MCARZ
. . Q
. W !,$$HEDSTAR("CONFIDENTIAL "_MCARZ,77) ; MC*2.3*33
. W !,MCARGNM_" "_SSN_" " W ?39-($L(MCARWARD_" "_MCARRB)\2),MCARWARD_" "_MCARRB,?79-$L(" DOB: "_MCARDOB)," DOB: "_MCARDOB
. Q
I +$G(MCFLG) W !,$$HEDSTAR(MCARZ,77)
W !,?39-($L("PROCEDURE DATE/TIME: "_MCARGDT2)\2),"PROCEDURE DATE/TIME: ",MCARGDT2
N FFF S $P(FFF,"- ",40)="- " W !,FFF,!
Q
HEDSTAR(X,X1) ; surround text string X with asterisks to length X1
N Y1
S (TY,Y1)="",$P(Y1," ",X1-$L(X)\2-1)=" ",TY=Y1_" "_X_" "
F I=$L(TY):1:X1 S TY=TY_" "
Q TY
MCPPROC ; Get require variables
D MCPPROC^MCARP1 Q
XTRCT(FULL) ;Extrinsic Function use to determine Full reporting or brief
Q $S($E($P(FULL,U),3)="B":0,1:1)
MCPROP(MCPROP) ; Medicine Procedure file entry validator
N TEMP,PREFIX,CNT
S PREFIX=$S($E(MCPROP,3,4)="ES":7,1:4),TEMP=""
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
Q TEMP