MCARHP ;WISC/SAE,TJK,WAA-PRINT HEMATOLOGY REPORTS ;9/18/98 10:18
;;2.3;Medicine;**15,16,19,33**;09/13/1996
LOOK ;
I +($G(MCARGDA))>0 G EN1 ; MC*2.3*33
D MCPPROC^MCARP
S DIC="^MCAR(694,",(MCFILE,MCFILE1)=+$P(DIC,"(",2),DIC(0)="AEZMQ"
S:MCESON DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
D ^DIC G EXIT:Y<0 S (MCARGDA,D0)=+Y
W !!
EN1 ;ENTRY POINT FROM SUMMARY OF PATIENT PROCEDURES ROUTINE
S MCARZ="HEMATOLOGY REPORT"
D:$G(MCESON) STATUS^MCESPRT(MCFILE,MCARGDA)
I $D(ORHFS) U IO G HEM ;dcm/slc added for CPRS
DEVQUE ; Device control and queuing control
K IO("Q") S %ZIS="MQ" D ^%ZIS G EXIT:POP
I $D(IO("Q")) S ZTRTN="HEM^MCARHP",(ZTSAVE("MC*"),ZTSAVE("DIC"))="",ZTDESC="Hematology Report" D ^%ZTLOAD K ZTSK G EXIT
U IO
HEM ; Print Report and entry point for queued report
INIT ; Initialize variables
K DXS,DIOT(2),^UTILITY($J),MCOUT
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
S X=MCARGDT D DTIME^MCARP S MCARGDT2=X D NOW^%DTC S X=% D DTIME^MCARP S MCARDTM=X
; ------------------------
; SSN = Enternal Format of the patients SSN with the first letter
; of the last name tacked on the end
; ------------------------
D DEM^VADPT S MCARGNM=VADM(1),SSN=VA("PID"),X=$P(VADM(3),"^",2),MCARDOB=$S(X'="":X,1:"") D KVAR^VADPT
D INP^VADPT S MCARWARD=$S(VAIN(4)'="":$P(VAIN(4),U,2),1:"NOT INPATIENT"),MCARRB=VAIN(5) D KVAR^VADPT
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"
HEMP ; Bone Marrow basic print (MCAROHB), and Differential (MCAROHD)
S MCFILET=MCFILE
D HEAD^MCARP D:MCBS ^MCOBHEM D:'MCBS ^MCAROHB K DXS G EXIT:$D(MCOUT)
I $D(^MCAR(694,D0,4)),'MCBS D ^MCAROHD K DXS G EXIT:$D(MCOUT)
D:'MCBS ^MCAROHF G EXIT:$D(MCOUT)
S MCFILE=MCFILET
D FOOTER^MCESPRT(MCFILE,MCARGDA)
R:$E(IOST,1,2)="C-" !!,"Press return to continue ",X:DTIME
G EXIT
BMB ; Print fields specific to BMB
G BMB2:'$D(^MCAR(694,D0,6)),BMB2:$P(^MCAR(694,D0,6),U,3)=""
S NP=$P(^MCAR(694,D0,6),U,3),FX=$P(^(6),U,2)
S FX=$S(FX="M":"Methanol",FX="E":"Ethanol",1:"Formalin")
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
W ?4,"GROSS DESCRIPTION: The specimen consisted of "_NP_" piece(s), measuring",!,?23
F AZ=1:1:NP S LP=$P(^MCAR(694,D0,6),U,AZ+3) W:LP'="" $S(AZ'=1:" mm, ",1:" "),LP
W " mm, submitted in "_FX_"."
W !!
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
BMB2 G BMB21:'$D(^MCAR(694,D0,9)) S X=^(9)
I $P(X,U,1)="Y" W ?6,"This specimen is submitted for decalcification in EDTA."
I $P(X,U,2)="Y" W !,?6,"Part of the specimen is fixed and submitted for processing in plastic."
BMB21 K X G BMBQ:$P(^MCAR(694,D0,0),U,6)="" W !!,?4,"BIOPSY COMMENTS:" K ^UTILITY($J,"W")
S DIWL=23,DIWR=IOM,DIWF="WC56",X=$P(^MCAR(694,D0,0),U,6) Q:$P(^(0),U,6)=""
D ^DIWP,^DIWW W !
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
BMBQ I $D(X),X=U S MCOUT=1
Q
UNRELP ;ENTRY POINT FOR SUPERVISOR TO PRINT UNRELEASED REPORT
S MCAREL="" G LOOK
REL S DIC="^MCAR(694,",DIC(0)="AEMZQ" D ^DIC G EXIT:Y<0
S $P(^MCAR(694,+Y,0),U,9)="Y"
W !,*7,"Report Released for Printing." R !,"* END * Press return to continue: ",X:DTIME
EXIT S:$D(ZTQUEUED) ZTREQ="@" K ZTSK
K %Y,LPDT,X,Y,DIC,IOP,MCARPPS,IJ,PT,D1,NE,NP,FX,AZ,PG,Z,L,FLDS,MCAREL,MCOUT,VA
K ^UTILITY($J),IO("Q"),MCARGDA,MCARGDT,SSN K MCARGNM,MCARGRTN,X,DFN,SSN
K MCARGNUM,MCARGNAM,MCARZ,DN,D0,MCARCODE,DIOEND,DIOBEG,DI,DICS,DICSS,MCARWARD,MCARDTM,MCARDOB,MCARRB,MCARGDT,MCOUNT,MCFOOTER
K DJ,BY,A,DIEDT,DIQ,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DQI,DU,DY
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
D ^%ZISC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARHP 3980 printed Oct 16, 2024@18:13:38 Page 2
MCARHP ;WISC/SAE,TJK,WAA-PRINT HEMATOLOGY REPORTS ;9/18/98 10:18
+1 ;;2.3;Medicine;**15,16,19,33**;09/13/1996
LOOK ;
+1 ; MC*2.3*33
IF +($GET(MCARGDA))>0
GOTO EN1
+2 DO MCPPROC^MCARP
+3 SET DIC="^MCAR(694,"
SET (MCFILE,MCFILE1)=+$PIECE(DIC,"(",2)
SET DIC(0)="AEZMQ"
+4 if MCESON
SET DIC("S")=$$PREVIEW^MCESSCR(MCFILE)
+5 DO ^DIC
if Y<0
GOTO EXIT
SET (MCARGDA,D0)=+Y
+6 WRITE !!
EN1 ;ENTRY POINT FROM SUMMARY OF PATIENT PROCEDURES ROUTINE
+1 SET MCARZ="HEMATOLOGY REPORT"
+2 if $GET(MCESON)
DO STATUS^MCESPRT(MCFILE,MCARGDA)
+3 ;dcm/slc added for CPRS
IF $DATA(ORHFS)
USE IO
GOTO HEM
DEVQUE ; Device control and queuing control
+1 KILL IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
+2 IF $DATA(IO("Q"))
SET ZTRTN="HEM^MCARHP"
SET (ZTSAVE("MC*"),ZTSAVE("DIC"))=""
SET ZTDESC="Hematology Report"
DO ^%ZTLOAD
KILL ZTSK
GOTO EXIT
+3 USE IO
HEM ; Print Report and entry point for queued report
INIT ; Initialize variables
+1 KILL DXS,DIOT(2),^UTILITY($JOB),MCOUT
+2 SET PG=0
SET D0=MCARGDA
SET DFN=$PIECE(^MCAR(694,D0,0),U,2)
SET MCARGDT=$PIECE(^(0),U)
SET MCARZ="HEMATOLOGY REPORT"
if MCESON
SET MCARZ=MCARZ_" - "_MCSTAT
+3 SET X=MCARGDT
DO DTIME^MCARP
SET MCARGDT2=X
DO NOW^%DTC
SET X=%
DO DTIME^MCARP
SET MCARDTM=X
+4 ; ------------------------
+5 ; SSN = Enternal Format of the patients SSN with the first letter
+6 ; of the last name tacked on the end
+7 ; ------------------------
+8 DO DEM^VADPT
SET MCARGNM=VADM(1)
SET SSN=VA("PID")
SET X=$PIECE(VADM(3),"^",2)
SET MCARDOB=$SELECT(X'="":X,1:"")
DO KVAR^VADPT
+9 DO INP^VADPT
SET MCARWARD=$SELECT(VAIN(4)'="":$PIECE(VAIN(4),U,2),1:"NOT INPATIENT")
SET MCARRB=VAIN(5)
DO KVAR^VADPT
+10 SET ^UTILITY($JOB,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"
HEMP ; Bone Marrow basic print (MCAROHB), and Differential (MCAROHD)
+1 SET MCFILET=MCFILE
+2 DO HEAD^MCARP
if MCBS
DO ^MCOBHEM
if 'MCBS
DO ^MCAROHB
KILL DXS
if $DATA(MCOUT)
GOTO EXIT
+3 IF $DATA(^MCAR(694,D0,4))
IF 'MCBS
DO ^MCAROHD
KILL DXS
if $DATA(MCOUT)
GOTO EXIT
+4 if 'MCBS
DO ^MCAROHF
if $DATA(MCOUT)
GOTO EXIT
+5 SET MCFILE=MCFILET
+6 DO FOOTER^MCESPRT(MCFILE,MCARGDA)
+7 if $EXTRACT(IOST,1,2)="C-"
READ !!,"Press return to continue ",X:DTIME
+8 GOTO EXIT
BMB ; Print fields specific to BMB
+1 if '$DATA(^MCAR(694,D0,6))
GOTO BMB2
if $PIECE(^MCAR(694,D0,6),U,3)=""
GOTO BMB2
+2 SET NP=$PIECE(^MCAR(694,D0,6),U,3)
SET FX=$PIECE(^(6),U,2)
+3 SET FX=$SELECT(FX="M":"Methanol",FX="E":"Ethanol",1:"Formalin")
+4 IF $Y>(IOSL-3)
IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press return to continue, '^' to escape: ",X:DTIME
if '$TEST
SET X=U
if X=U
GOTO BMBQ
DO HEAD^MCARP
+5 WRITE ?4,"GROSS DESCRIPTION: The specimen consisted of "_NP_" piece(s), measuring",!,?23
+6 FOR AZ=1:1:NP
SET LP=$PIECE(^MCAR(694,D0,6),U,AZ+3)
if LP'=""
WRITE $SELECT(AZ'=1:" mm, ",1:" "),LP
+7 WRITE " mm, submitted in "_FX_"."
+8 WRITE !!
+9 IF $Y>(IOSL-3)
IF ($EXTRACT(IOST,1,2)="C-")
READ !!,"Press return to continue, '^' to escape: ",X:DTIME
if '$TEST
SET X=U
if X=U
GOTO BMBQ
DO HEAD^MCARP
BMB2 if '$DATA(^MCAR(694,D0,9))
GOTO BMB21
SET X=^(9)
+1 IF $PIECE(X,U,1)="Y"
WRITE ?6,"This specimen is submitted for decalcification in EDTA."
+2 IF $PIECE(X,U,2)="Y"
WRITE !,?6,"Part of the specimen is fixed and submitted for processing in plastic."
BMB21 KILL X
if $PIECE(^MCAR(694,D0,0),U,6)=""
GOTO BMBQ
WRITE !!,?4,"BIOPSY COMMENTS:"
KILL ^UTILITY($JOB,"W")
+1 SET DIWL=23
SET DIWR=IOM
SET DIWF="WC56"
SET X=$PIECE(^MCAR(694,D0,0),U,6)
if $PIECE(^(0),U,6)=""
QUIT
+2 DO ^DIWP
DO ^DIWW
WRITE !
+3 KILL X
IF $Y>(IOSL-3)
IF ($EXTRACT(IOST,1,2)="C-")
READ !!,"Press return to continue, '^' to escape: ",X:DTIME
if '$TEST
SET X=U
if X=U
GOTO BMBQ
DO HEAD^MCARP
BMBQ IF $DATA(X)
IF X=U
SET MCOUT=1
+1 QUIT
UNRELP ;ENTRY POINT FOR SUPERVISOR TO PRINT UNRELEASED REPORT
+1 SET MCAREL=""
GOTO LOOK
REL SET DIC="^MCAR(694,"
SET DIC(0)="AEMZQ"
DO ^DIC
if Y<0
GOTO EXIT
+1 SET $PIECE(^MCAR(694,+Y,0),U,9)="Y"
+2 WRITE !,*7,"Report Released for Printing."
READ !,"* END * Press return to continue: ",X:DTIME
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ZTSK
+1 KILL %Y,LPDT,X,Y,DIC,IOP,MCARPPS,IJ,PT,D1,NE,NP,FX,AZ,PG,Z,L,FLDS,MCAREL,MCOUT,VA
+2 KILL ^UTILITY($JOB),IO("Q"),MCARGDA,MCARGDT,SSN
KILL MCARGNM,MCARGRTN,X,DFN,SSN
+3 KILL MCARGNUM,MCARGNAM,MCARZ,DN,D0,MCARCODE,DIOEND,DIOBEG,DI,DICS,DICSS,MCARWARD,MCARDTM,MCARDOB,MCARRB,MCARGDT,MCOUNT,MCFOOTER
+4 KILL DJ,BY,A,DIEDT,DIQ,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DQI,DU,DY
+5 KILL S,LP,DC,DL,DV,DE,DA,DK,Y,R,C,D,I,J,Q,M,P,N,D1,DIW,DIWL,DIWR,DIWF,DIWT
+6 DO ^%ZISC
QUIT
