137 lines
5.8 KiB
Mathematica
137 lines
5.8 KiB
Mathematica
|
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
|