- 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
- 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."
- EXIT IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL ZTSK
- +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
