BHSNRS ;IHS/MSC/MGH - Health Summary for NRS and imaging ;08-Dec-2010 13:34;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**4**;March 17, 2006;Build 13
;==============================================================
; IHS/CMI/LAB - PART 8 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
NRS ; ******************* NRS - LAST 3 * 9000010.49 *******
; <SETUP>
N BHSPAT,BHSCNT,BHSEX
S BHSPAT=DFN
Q:'$D(^AUPNVNTS("AA",BHSPAT))
; <DISPLAY>
D NRDSP3
; <CLEANUP>
K BHST,BHSFN
NRS3X K BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHRISK,BHSPR,BHSQ,BHSREF,BHSX,C,MIEN
Q
NRDSP3 ;get NRS type
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?1,"DATE",?12,"PROVIDER",?32,"RISK",?72,"RD ",!?72,"REFERRAL",!!
S BHSCNT=0,BHSEX=0
F S BHSEX=$O(^AUPNVNTS("AA",BHSPAT,BHSEX)) Q:BHSEX'=+BHSEX!($D(GMTSQIT))!(BHSCNT>3) D
.S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVNTS("AA",BHSPAT,BHSEX,BHSIVD)) S BHSCNT=BHSCNT+1 Q:BHSIVD=""!(BHSCNT>3)!($D(GMTSQIT)) D NRDSP13
Q
NRDSP13 ;get NRS test DFN
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVNTS("AA",BHSPAT,BHSEX,BHSIVD,BHSDFN)) Q:'BHSDFN!(BHSCNT>3)!($D(GMTSQIT)) D NRDSP23
Q
NRDSP23 ;compile data & display NRS test
S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
Q:'$D(^AUPNVNTS(BHSDFN,0))
S BHSPR=$E($$VAL^XBDIQ1(9000010.49,BHSDFN,1204),1,18)
S BHSREF=$S($P(^AUPNVNTS(BHSDFN,0),U,15):"Yes",1:"No")
S BHRISK=$$VAL^XBDIQ1(9000010.49,BHSDFN,.14) I BHRISK]"" S BHRISK=BHRISK_": "
S C=0 I $P(^AUPNVNTS(BHSDFN,0),U,4) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Age 70+"
I $P(^AUPNVNTS(BHSDFN,0),U,5) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Nut Supp"
I $P(^AUPNVNTS(BHSDFN,0),U,6) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Weight"
I $P(^AUPNVNTS(BHSDFN,0),U,7) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Diagnosis"
I $P(^AUPNVNTS(BHSDFN,0),U,8) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Appetite"
I $P(^AUPNVNTS(BHSDFN,0),U,9) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Diff Chew"
I $P(^AUPNVNTS(BHSDFN,0),U,10) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Food Aller/Intol"
I $P(^AUPNVNTS(BHSDFN,0),U,11) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Vom/Diarr"
I $P(^AUPNVNTS(BHSDFN,0),U,12) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Other: "_$P(^AUPNVNTS(BHSDFN,0),U,13)
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?1,BHSDAT,?12,BHSPR
K ^UTILITY($J,"W") S X=BHRISK,DIWL=0,DIWR=40 D ^DIWP
W ?32,^UTILITY($J,"W",0,1,0)
W ?74,BHSREF,!
F BHSX=2:1:$G(^UTILITY($J,"W",0)) D Q:$D(GMTSQIT)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?32,^UTILITY($J,"W",0,BHSX,0),!
K ^UTILITY($J)
Q
;
IMAGING ; EP FOR NEW COMPONENT
S BHSPAT=DFN
Q:'$D(^RADPT(BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
K BHSARR
D SVR(BHSPAT,$S(GMTSNDM=-1:9999999,1:GMTSNDM),$S(GMTSDLM=9999999:0,1:(9999999-GMTSDLM)),.BHSARR)
D PRINT(.BHSARR)
K BHSARR
Q
SVR(DFN,MAX,START,LINE) ; RADIOLOGY REPORTS
I $G(DFN),$G(MAX),$G(START)]""
E Q
N X,Y,Z,T,%,IDT,IDT2,EDT,GBL,PCC,RIEN,ARR,EXDT
N CASE,ESTAT,PRIEN,RCIEN,RDFN,RDOC,RSTAT,CNT,CPT,CPTIEN,MOD,PCE,PMIEN,PROC,TAB,TOT
S IDT=0,T="~",CNT=0
S IDT2=9999999-START
S GBL=$NA(^RADPT(DFN,"DT"))
RPASS1 ;
F Q:CNT>MAX S IDT=$O(@GBL@(IDT)) Q:'IDT Q:IDT>IDT2 D
. S EDT=+$G(@GBL@(IDT,0)) I 'EDT Q
. S EXDT=$$FMTE^XLFDT(EDT,2),EXDT=$TR(EXDT,"@"," "),EXDT=$P(EXDT,":",1,2)
. S RCIEN=0
. F S RCIEN=$O(@GBL@(IDT,"P",RCIEN)) Q:'RCIEN D
.. S X=$G(@GBL@(IDT,"P",RCIEN,0)) I X="" Q
.. S RIEN=$P(X,U,17) I RIEN="" Q
.. S RSTAT="",%=$P($G(^RARPT(RIEN,0)),U,5)
.. I $L(%) S RSTAT=$S(%="V":"VERIFIED",%="R":"RELEASED/NOT VERIFIED",%="PD":"PROBLEM DRAFT",%="D":"DRAFT",1:"")
.. S CNT=CNT+1 ; DONT WORRY ABOUT THE COUNT UNTIL THE NEXT DATE
.. S CASE=$P(X,U) I CASE="" Q
.. S ESTAT="",%=$P(X,U,3) ; NEEDS TRANSLATION
.. I % S ESTAT=$P($G(^RA(72,%,0)),U)
.. S RDFN=$P(X,U,15),RDOC=""
.. I RDFN S RDOC=$P($G(^VA(200,RDFN,0)),U)
.. S PRIEN=$P(X,U,2) I 'PRIEN Q
.. S Y=$G(^RAMIS(71,PRIEN,0)) I Y="" Q
.. S PROC=$P(Y,U) I PROC="" Q
.. S CPTIEN=+$P(Y,U,9)
.. S CPT=$P($G(^ICPT(CPTIEN,0)),U)
.. S MIEN=0,MOD=""
.. F S MIEN=$O(@GBL@(IDT,"P",RCIEN,"M",MIEN)) Q:'MIEN D
... S PMIEN=+$G(@GBL@(IDT,"P",RCIEN,"M",MIEN,0)) I 'PMIEN Q
... S %=$P($G(^RAMIS(71.2,PMIEN,0)),U) I %="" Q
... I MOD'="" S MOD=MOD_", "
... S MOD=MOD_%
... Q
.. S ARR(CNT)=EXDT_T_PROC_T_MOD_T_CPT_T_RDOC_T_CASE_T_ESTAT_T_RSTAT
.. S Z=0
.. F S Z=$O(@GBL@(IDT,"P",RCIEN,"H",Z)) Q:'Z S ARR(CNT,"H",Z)=$G(@GBL@(IDT,"P",RCIEN,"H",Z,0)) ; HX
.. S Z=0
.. F S Z=$O(^RARPT(RIEN,"R",Z)) Q:'Z S ARR(CNT,"R",Z)=$G(^RARPT(RIEN,"R",Z,0)) ; REPORT
.. S Z=0
.. F S Z=$O(^RARPT(RIEN,"I",Z)) Q:'Z S ARR(CNT,"I",Z)=$G(^RARPT(RIEN,"I",Z,0)) ; IMPRESSION
.. Q
. Q
RPASS2 ;
S ARR="HEADER"_T_"Procedure: "_T_"Procedure Modifier: "_T_"CPT Code: "_T_"Interpreting Staff: "_T_"Exam Case Number: "_T_"Exam Status: "_T_"Report Status: "
S CNT=0,LINE(1)="----- IMAGING PROFILE -----",LINE=1,TAB=" "
F S CNT=$O(ARR(CNT)) Q:'CNT D
. S TOT=$L(ARR(CNT),T) I 'TOT Q
. F PCE=1:1:TOT D
.. I PCE=1 S X=$P(ARR(CNT),T,1)_" "_$P(ARR(CNT),T,2),PCE=2
.. E S X=TAB_$P(ARR,T,PCE)_$P(ARR(CNT),T,PCE)
.. S LINE=LINE+1
.. S LINE(LINE)=X
.. Q
. S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
. S LINE(LINE)=TAB_"History: "
. S Z=0
. F S Z=$O(ARR(CNT,"H",Z)) Q:'Z D
.. S LINE=LINE+1
.. S LINE(LINE)=TAB_" "_ARR(CNT,"H",Z)
.. Q
. S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
. S LINE(LINE)=TAB_"Report: "
. S Z=0
. F S Z=$O(ARR(CNT,"R",Z)) Q:'Z D
.. S LINE=LINE+1
.. S LINE(LINE)=TAB_" "_ARR(CNT,"R",Z)
.. Q
. S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
. S LINE(LINE)=TAB_"Impression: "
. S Z=0
. F S Z=$O(ARR(CNT,"I",Z)) Q:'Z D
.. S LINE=LINE+1
.. S LINE(LINE)=TAB_" "_ARR(CNT,"I",Z)
.. Q
. Q
Q
;
PRINT(LINE) ; EP-PRINT RESULTS
N CNT
S CNT=0
F S CNT=$O(LINE(CNT)) Q:'CNT D I $D(GMTSQIT) Q
. ;W !
. D CKP^GMTSUP Q:$D(GMTSQIT)
. S X=$G(LINE(CNT))
. D WP(X)
. Q
Q
WP(X) ;Do word wrap
N DIWF,DIWL,DIWR
S DIWF="",DIWL=0,DIWR=75
D ^DIWP
S RAX=0 F S RAX=$O(^UTILITY($J,"W",DIWL,RAX)) Q:RAX'>0 D
.I RAX=1 W ?5,^UTILITY($J,"W",DIWL,RAX,0),!
.I RAX>1 W ?9,^UTILITY($J,"W",DIWL,RAX,0),!
K ^UTILITY($J,"W")
Q
;
BHSNRS ;IHS/MSC/MGH - Health Summary for NRS and imaging ;08-Dec-2010 13:34;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4**;March 17, 2006;Build 13
+2 ;==============================================================
+3 ; IHS/CMI/LAB - PART 8 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+4 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+5 ;
NRS ; ******************* NRS - LAST 3 * 9000010.49 *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSCNT,BHSEX
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVNTS("AA",BHSPAT))
QUIT
+5 ; <DISPLAY>
+6 DO NRDSP3
+7 ; <CLEANUP>
+8 KILL BHST,BHSFN
NRS3X KILL BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y
+1 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHRISK,BHSPR,BHSQ,BHSREF,BHSX,C,MIEN
+2 QUIT
NRDSP3 ;get NRS type
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 WRITE ?1,"DATE",?12,"PROVIDER",?32,"RISK",?72,"RD ",!?72,"REFERRAL",!!
+3 SET BHSCNT=0
SET BHSEX=0
+4 FOR
SET BHSEX=$ORDER(^AUPNVNTS("AA",BHSPAT,BHSEX))
IF BHSEX'=+BHSEX!($DATA(GMTSQIT))!(BHSCNT>3)
QUIT
Begin DoDot:1
+5 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVNTS("AA",BHSPAT,BHSEX,BHSIVD))
SET BHSCNT=BHSCNT+1
IF BHSIVD=""!(BHSCNT>3)!($DATA(GMTSQIT))
QUIT
DO NRDSP13
End DoDot:1
+6 QUIT
NRDSP13 ;get NRS test DFN
+1 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+2 SET BHSDFN=0
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVNTS("AA",BHSPAT,BHSEX,BHSIVD,BHSDFN))
IF 'BHSDFN!(BHSCNT>3)!($DATA(GMTSQIT))
QUIT
DO NRDSP23
+3 QUIT
NRDSP23 ;compile data & display NRS test
+1 SET X=-BHSIVD\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+2 IF '$DATA(^AUPNVNTS(BHSDFN,0))
QUIT
+3 SET BHSPR=$EXTRACT($$VAL^XBDIQ1(9000010.49,BHSDFN,1204),1,18)
+4 SET BHSREF=$SELECT($PIECE(^AUPNVNTS(BHSDFN,0),U,15):"Yes",1:"No")
+5 SET BHRISK=$$VAL^XBDIQ1(9000010.49,BHSDFN,.14)
IF BHRISK]""
SET BHRISK=BHRISK_": "
+6 SET C=0
IF $PIECE(^AUPNVNTS(BHSDFN,0),U,4)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Age 70+"
+7 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,5)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Nut Supp"
+8 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,6)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Weight"
+9 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,7)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Diagnosis"
+10 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,8)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Appetite"
+11 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,9)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Diff Chew"
+12 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,10)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Food Aller/Intol"
+13 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,11)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Vom/Diarr"
+14 IF $PIECE(^AUPNVNTS(BHSDFN,0),U,12)
SET C=C+1
IF C>1
SET BHRISK=BHRISK_"; "
SET BHRISK=BHRISK_"Other: "_$PIECE(^AUPNVNTS(BHSDFN,0),U,13)
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+16 WRITE ?1,BHSDAT,?12,BHSPR
+17 KILL ^UTILITY($JOB,"W")
SET X=BHRISK
SET DIWL=0
SET DIWR=40
DO ^DIWP
+18 WRITE ?32,^UTILITY($JOB,"W",0,1,0)
+19 WRITE ?74,BHSREF,!
+20 FOR BHSX=2:1:$GET(^UTILITY($JOB,"W",0))
Begin DoDot:1
+21 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+22 WRITE ?32,^UTILITY($JOB,"W",0,BHSX,0),!
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+23 KILL ^UTILITY($JOB)
+24 QUIT
+25 ;
IMAGING ; EP FOR NEW COMPONENT
+1 SET BHSPAT=DFN
+2 IF '$DATA(^RADPT(BHSPAT))
QUIT
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 KILL BHSARR
+5 DO SVR(BHSPAT,$SELECT(GMTSNDM=-1:9999999,1:GMTSNDM),$SELECT(GMTSDLM=9999999:0,1:(9999999-GMTSDLM)),.BHSARR)
+6 DO PRINT(.BHSARR)
+7 KILL BHSARR
+8 QUIT
SVR(DFN,MAX,START,LINE) ; RADIOLOGY REPORTS
+1 IF $GET(DFN)
IF $GET(MAX)
IF $GET(START)]""
+2 IF '$TEST
QUIT
+3 NEW X,Y,Z,T,%,IDT,IDT2,EDT,GBL,PCC,RIEN,ARR,EXDT
+4 NEW CASE,ESTAT,PRIEN,RCIEN,RDFN,RDOC,RSTAT,CNT,CPT,CPTIEN,MOD,PCE,PMIEN,PROC,TAB,TOT
+5 SET IDT=0
SET T="~"
SET CNT=0
+6 SET IDT2=9999999-START
+7 SET GBL=$NAME(^RADPT(DFN,"DT"))
RPASS1 ;
+1 FOR
IF CNT>MAX
QUIT
SET IDT=$ORDER(@GBL@(IDT))
IF 'IDT
QUIT
IF IDT>IDT2
QUIT
Begin DoDot:1
+2 SET EDT=+$GET(@GBL@(IDT,0))
IF 'EDT
QUIT
+3 SET EXDT=$$FMTE^XLFDT(EDT,2)
SET EXDT=$TRANSLATE(EXDT,"@"," ")
SET EXDT=$PIECE(EXDT,":",1,2)
+4 SET RCIEN=0
+5 FOR
SET RCIEN=$ORDER(@GBL@(IDT,"P",RCIEN))
IF 'RCIEN
QUIT
Begin DoDot:2
+6 SET X=$GET(@GBL@(IDT,"P",RCIEN,0))
IF X=""
QUIT
+7 SET RIEN=$PIECE(X,U,17)
IF RIEN=""
QUIT
+8 SET RSTAT=""
SET %=$PIECE($GET(^RARPT(RIEN,0)),U,5)
+9 IF $LENGTH(%)
SET RSTAT=$SELECT(%="V":"VERIFIED",%="R":"RELEASED/NOT VERIFIED",%="PD":"PROBLEM DRAFT",%="D":"DRAFT",1:"")
+10 ; DONT WORRY ABOUT THE COUNT UNTIL THE NEXT DATE
SET CNT=CNT+1
+11 SET CASE=$PIECE(X,U)
IF CASE=""
QUIT
+12 ; NEEDS TRANSLATION
SET ESTAT=""
SET %=$PIECE(X,U,3)
+13 IF %
SET ESTAT=$PIECE($GET(^RA(72,%,0)),U)
+14 SET RDFN=$PIECE(X,U,15)
SET RDOC=""
+15 IF RDFN
SET RDOC=$PIECE($GET(^VA(200,RDFN,0)),U)
+16 SET PRIEN=$PIECE(X,U,2)
IF 'PRIEN
QUIT
+17 SET Y=$GET(^RAMIS(71,PRIEN,0))
IF Y=""
QUIT
+18 SET PROC=$PIECE(Y,U)
IF PROC=""
QUIT
+19 SET CPTIEN=+$PIECE(Y,U,9)
+20 SET CPT=$PIECE($GET(^ICPT(CPTIEN,0)),U)
+21 SET MIEN=0
SET MOD=""
+22 FOR
SET MIEN=$ORDER(@GBL@(IDT,"P",RCIEN,"M",MIEN))
IF 'MIEN
QUIT
Begin DoDot:3
+23 SET PMIEN=+$GET(@GBL@(IDT,"P",RCIEN,"M",MIEN,0))
IF 'PMIEN
QUIT
+24 SET %=$PIECE($GET(^RAMIS(71.2,PMIEN,0)),U)
IF %=""
QUIT
+25 IF MOD'=""
SET MOD=MOD_", "
+26 SET MOD=MOD_%
+27 QUIT
End DoDot:3
+28 SET ARR(CNT)=EXDT_T_PROC_T_MOD_T_CPT_T_RDOC_T_CASE_T_ESTAT_T_RSTAT
+29 SET Z=0
+30 ; HX
FOR
SET Z=$ORDER(@GBL@(IDT,"P",RCIEN,"H",Z))
IF 'Z
QUIT
SET ARR(CNT,"H",Z)=$GET(@GBL@(IDT,"P",RCIEN,"H",Z,0))
+31 SET Z=0
+32 ; REPORT
FOR
SET Z=$ORDER(^RARPT(RIEN,"R",Z))
IF 'Z
QUIT
SET ARR(CNT,"R",Z)=$GET(^RARPT(RIEN,"R",Z,0))
+33 SET Z=0
+34 ; IMPRESSION
FOR
SET Z=$ORDER(^RARPT(RIEN,"I",Z))
IF 'Z
QUIT
SET ARR(CNT,"I",Z)=$GET(^RARPT(RIEN,"I",Z,0))
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
RPASS2 ;
+1 SET ARR="HEADER"_T_"Procedure: "_T_"Procedure Modifier: "_T_"CPT Code: "_T_"Interpreting Staff: "_T_"Exam Case Number: "_T_"Exam Status: "_T_"Report Status: "
+2 SET CNT=0
SET LINE(1)="----- IMAGING PROFILE -----"
SET LINE=1
SET TAB=" "
+3 FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+4 SET TOT=$LENGTH(ARR(CNT),T)
IF 'TOT
QUIT
+5 FOR PCE=1:1:TOT
Begin DoDot:2
+6 IF PCE=1
SET X=$PIECE(ARR(CNT),T,1)_" "_$PIECE(ARR(CNT),T,2)
SET PCE=2
+7 IF '$TEST
SET X=TAB_$PIECE(ARR,T,PCE)_$PIECE(ARR(CNT),T,PCE)
+8 SET LINE=LINE+1
+9 SET LINE(LINE)=X
+10 QUIT
End DoDot:2
+11 SET LINE=LINE+1
SET LINE(LINE)=" "
SET LINE=LINE+1
+12 SET LINE(LINE)=TAB_"History: "
+13 SET Z=0
+14 FOR
SET Z=$ORDER(ARR(CNT,"H",Z))
IF 'Z
QUIT
Begin DoDot:2
+15 SET LINE=LINE+1
+16 SET LINE(LINE)=TAB_" "_ARR(CNT,"H",Z)
+17 QUIT
End DoDot:2
+18 SET LINE=LINE+1
SET LINE(LINE)=" "
SET LINE=LINE+1
+19 SET LINE(LINE)=TAB_"Report: "
+20 SET Z=0
+21 FOR
SET Z=$ORDER(ARR(CNT,"R",Z))
IF 'Z
QUIT
Begin DoDot:2
+22 SET LINE=LINE+1
+23 SET LINE(LINE)=TAB_" "_ARR(CNT,"R",Z)
+24 QUIT
End DoDot:2
+25 SET LINE=LINE+1
SET LINE(LINE)=" "
SET LINE=LINE+1
+26 SET LINE(LINE)=TAB_"Impression: "
+27 SET Z=0
+28 FOR
SET Z=$ORDER(ARR(CNT,"I",Z))
IF 'Z
QUIT
Begin DoDot:2
+29 SET LINE=LINE+1
+30 SET LINE(LINE)=TAB_" "_ARR(CNT,"I",Z)
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 QUIT
+34 ;
PRINT(LINE) ; EP-PRINT RESULTS
+1 NEW CNT
+2 SET CNT=0
+3 FOR
SET CNT=$ORDER(LINE(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+4 ;W !
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 SET X=$GET(LINE(CNT))
+7 DO WP(X)
+8 QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+9 QUIT
WP(X) ;Do word wrap
+1 NEW DIWF,DIWL,DIWR
+2 SET DIWF=""
SET DIWL=0
SET DIWR=75
+3 DO ^DIWP
+4 SET RAX=0
FOR
SET RAX=$ORDER(^UTILITY($JOB,"W",DIWL,RAX))
IF RAX'>0
QUIT
Begin DoDot:1
+5 IF RAX=1
WRITE ?5,^UTILITY($JOB,"W",DIWL,RAX,0),!
+6 IF RAX>1
WRITE ?9,^UTILITY($JOB,"W",DIWL,RAX,0),!
End DoDot:1
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT
+9 ;
