source: FOIAVistA/trunk/r/MEDICINE-MC/MCARP.m@ 1806

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