source: FOIAVistA/trunk/r/MEDICINE-MC/MCARHP.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.8 KB
Line 
1MCARHP ;WISC/SAE,TJK,WAA-PRINT HEMATOLOGY REPORTS ;9/18/98 10:18
2 ;;2.3;Medicine;**15,16,19,33**;09/13/1996
3LOOK ;
4 I +($G(MCARGDA))>0 G EN1 ; MC*2.3*33
5 D MCPPROC^MCARP
6 S DIC="^MCAR(694,",(MCFILE,MCFILE1)=+$P(DIC,"(",2),DIC(0)="AEZMQ"
7 S:MCESON DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
8 D ^DIC G EXIT:Y<0 S (MCARGDA,D0)=+Y
9 W !!
10EN1 ;ENTRY POINT FROM SUMMARY OF PATIENT PROCEDURES ROUTINE
11 S MCARZ="HEMATOLOGY REPORT"
12 D:$G(MCESON) STATUS^MCESPRT(MCFILE,MCARGDA)
13 I $D(ORHFS) U IO G HEM ;dcm/slc added for CPRS
14DEVQUE ; Device control and queuing control
15 K IO("Q") S %ZIS="MQ" D ^%ZIS G EXIT:POP
16 I $D(IO("Q")) S ZTRTN="HEM^MCARHP",(ZTSAVE("MC*"),ZTSAVE("DIC"))="",ZTDESC="Hematology Report" D ^%ZTLOAD K ZTSK G EXIT
17 U IO
18HEM ; Print Report and entry point for queued report
19INIT ; Initialize variables
20 K DXS,DIOT(2),^UTILITY($J),MCOUT
21 S PG=0,D0=MCARGDA,DFN=$P(^MCAR(694,D0,0),U,2),MCARGDT=$P(^(0),U),MCARZ="HEMATOLOGY REPORT" S:MCESON MCARZ=MCARZ_" - "_MCSTAT
22 S X=MCARGDT D DTIME^MCARP S MCARGDT2=X D NOW^%DTC S X=% D DTIME^MCARP S MCARDTM=X
23 ; ------------------------
24 ; SSN = Enternal Format of the patients SSN with the first letter
25 ; of the last name tacked on the end
26 ; ------------------------
27 D DEM^VADPT S MCARGNM=VADM(1),SSN=VA("PID"),X=$P(VADM(3),"^",2),MCARDOB=$S(X'="":X,1:"") D KVAR^VADPT
28 D INP^VADPT S MCARWARD=$S(VAIN(4)'="":$P(VAIN(4),U,2),1:"NOT INPATIENT"),MCARRB=VAIN(5) D KVAR^VADPT
29 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"
30HEMP ; Bone Marrow basic print (MCAROHB), and Differential (MCAROHD)
31 S MCFILET=MCFILE
32 D HEAD^MCARP D:MCBS ^MCOBHEM D:'MCBS ^MCAROHB K DXS G EXIT:$D(MCOUT)
33 I $D(^MCAR(694,D0,4)),'MCBS D ^MCAROHD K DXS G EXIT:$D(MCOUT)
34 D:'MCBS ^MCAROHF G EXIT:$D(MCOUT)
35 S MCFILE=MCFILET
36 D FOOTER^MCESPRT(MCFILE,MCARGDA)
37 R:$E(IOST,1,2)="C-" !!,"Press return to continue ",X:DTIME
38 G EXIT
39BMB ; Print fields specific to BMB
40 G BMB2:'$D(^MCAR(694,D0,6)),BMB2:$P(^MCAR(694,D0,6),U,3)=""
41 S NP=$P(^MCAR(694,D0,6),U,3),FX=$P(^(6),U,2)
42 S FX=$S(FX="M":"Methanol",FX="E":"Ethanol",1:"Formalin")
43 I $Y>(IOSL-3),$E(IOST,1,2)="C-" R !!,"Press return to continue, '^' to escape: ",X:DTIME S:'$T X=U G:X=U BMBQ D HEAD^MCARP
44 W ?4,"GROSS DESCRIPTION: The specimen consisted of "_NP_" piece(s), measuring",!,?23
45 F AZ=1:1:NP S LP=$P(^MCAR(694,D0,6),U,AZ+3) W:LP'="" $S(AZ'=1:" mm, ",1:" "),LP
46 W " mm, submitted in "_FX_"."
47 W !!
48 I $Y>(IOSL-3),($E(IOST,1,2)="C-") R !!,"Press return to continue, '^' to escape: ",X:DTIME S:'$T X=U G:X=U BMBQ D HEAD^MCARP
49BMB2 G BMB21:'$D(^MCAR(694,D0,9)) S X=^(9)
50 I $P(X,U,1)="Y" W ?6,"This specimen is submitted for decalcification in EDTA."
51 I $P(X,U,2)="Y" W !,?6,"Part of the specimen is fixed and submitted for processing in plastic."
52BMB21 K X G BMBQ:$P(^MCAR(694,D0,0),U,6)="" W !!,?4,"BIOPSY COMMENTS:" K ^UTILITY($J,"W")
53 S DIWL=23,DIWR=IOM,DIWF="WC56",X=$P(^MCAR(694,D0,0),U,6) Q:$P(^(0),U,6)=""
54 D ^DIWP,^DIWW W !
55 K X I $Y>(IOSL-3),($E(IOST,1,2)="C-") R !!,"Press return to continue, '^' to escape: ",X:DTIME S:'$T X=U G:X=U BMBQ D HEAD^MCARP
56BMBQ I $D(X),X=U S MCOUT=1
57 Q
58UNRELP ;ENTRY POINT FOR SUPERVISOR TO PRINT UNRELEASED REPORT
59 S MCAREL="" G LOOK
60REL S DIC="^MCAR(694,",DIC(0)="AEMZQ" D ^DIC G EXIT:Y<0
61 S $P(^MCAR(694,+Y,0),U,9)="Y"
62 W !,*7,"Report Released for Printing." R !,"* END * Press return to continue: ",X:DTIME
63EXIT S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
64 K %Y,LPDT,X,Y,DIC,IOP,MCARPPS,IJ,PT,D1,NE,NP,FX,AZ,PG,Z,L,FLDS,MCAREL,MCOUT,VA
65 K ^UTILITY($J),IO("Q"),MCARGDA,MCARGDT,SSN K MCARGNM,MCARGRTN,X,DFN,SSN
66 K MCARGNUM,MCARGNAM,MCARZ,DN,D0,MCARCODE,DIOEND,DIOBEG,DI,DICS,DICSS,MCARWARD,MCARDTM,MCARDOB,MCARRB,MCARGDT,MCOUNT,MCFOOTER
67 K DJ,BY,A,DIEDT,DIQ,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DQI,DU,DY
68 K S,LP,DC,DL,DV,DE,DA,DK,Y,R,C,D,I,J,Q,M,P,N,D1,DIW,DIWL,DIWR,DIWF,DIWT
69 D ^%ZISC Q
Note: See TracBrowser for help on using the repository browser.