ORWRP ; ALB/MJK,dcm Report Calls ;23-Nov-2011 11:55;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,1002,194,227,215,262,243,1010**;Dec 17, 1997;Build 47
;Modified - IHS/CIA/DKM - 2/27/07 - Line GETHS+15, RPT+45
LABLIST(LST) ; -- report list for labs tab
; RPC: ORWRP LAB REPORT LIST
N I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD
S EOF="$$END",ROOT=$NA(LST),(CNT,I)=0
D SETITEM(ROOT,"[LAB REPORT LIST]")
D GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST")
F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D
. Q:$P(X0,"^",12)="L"
. S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
. I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
. S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
. D SETITEM(.ROOT,X)
D SETITEM(.ROOT,"$$END")
Q
LIST(LST) ; -- report lists for reports tab
; RPC: ORWRP REPORT LIST
N EOF,ROOT
S EOF="$$END",ROOT=$NA(LST)
K @ROOT
D GETRPTS(.ROOT,.EOF) ; -report list
D GETHS(.ROOT,.EOF) ; -health summary types
D GETDT(.ROOT,.EOF) ; -date ranges
Q
GETCOL(ROOT,IFN) ; -- get Column headers for ListView
N I,J,X,VAL
Q:'$G(IFN)
S I=0,ROOT=$NA(ROOT)
F S I=$O(^ORD(101.24,IFN,3,"C",I)) Q:'I D
. S VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I"),J=0
. F S J=$O(^ORD(101.24,IFN,3,"C",I,J)) Q:'J I $D(^ORD(101.24,IFN,3,J)) S X=^(J,0) D
.. I $L(VAL),$P(VAL,",",I) S $P(X,"^",10)=$P(VAL,",",I)
.. D SETITEM(.ROOT,X)
Q
GETRPTS(ROOT,EOF) ; -- get report list
N I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD
D SETITEM(.ROOT,"[REPORT LIST]"),GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST")
S (CNT,I)=0
F S I=$O(ORLIST(I)) Q:'I Q:'$D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0),X2=$G(^(2)) D
. Q:$P(X0,"^",12)="L"
. S RPC=$$GET1^DIQ(8994,+$P(X0,"^",13),.01),IFN=ORLIST(I),HEAD=$P(X0,"^")
. I $L($P(X2,"^",3)) S HEAD=$P(X2,"^",3)
. S X=$P(X0,"^",2)_"^"_HEAD_"^"_$P(X0,"^",4)_"^"_$P(X0,"^",19)_";"_$P(X0,"^",20)_"^"_$P(X0,"^",6)_"^"_$P(X0,"^",5)_"^"_$P(X0,"^",3)_"^"_$P(X0,"^",12)_"^"_$P(X0,"^",7)_"^"_RPC_"^"_IFN
. D SETITEM(.ROOT,X)
D SETITEM(.ROOT,"$$END")
Q
GETHS(ROOT,EOF) ; --get health summary types
N C,I,IFN,ORHSPARM,ORERR,X,T
K ^TMP("ORHSPARM",$J)
S ORHSROOT="^TMP(""ORHSPARM"",$J)"
I $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) S I="",C=0 D
. F S I=$O(^GMT(142,"B",I)) Q:I="" S IFN=$O(^(I,0)) Q:'IFN D
.. S X=$G(^GMT(142,IFN,0)) Q:'$L(X)
.. S T=$G(^GMT(142,IFN,"T")),C=C+1,@ORHSROOT@(C)=IFN_"^"_$S($L(T):T,1:$P(X,"^"))_"^^^^^1"
.. I I="GMTS HS ADHOC OPTION" S @ORHSROOT@(C)="0^GMTS Adhoc Report"
I '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1) D
. D:$L($T(GETLIST^GMTSXAL)) GETLIST^GMTSXAL($NA(@ORHSROOT),$G(DUZ),1,.ORERR)
. Q:$G(ORERR)
. S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I S @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1" I $P(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION" S @ORHSROOT@(I)="0^Adhoc Report"
D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
S I=0 F S I=$O(@ORHSROOT@(I)) Q:'I D SETITEM(.ROOT,"h"_@ORHSROOT@(I))
D GETHS^ORWRPBHS(.ROOT,.EOF) ; IHS/CIA/DKM - Support for IHS health summaries
D SETITEM(.ROOT,EOF)
Q
GETDT(ROOT,EOF) ; -- get date range choices
N I,X
D SETITEM(.ROOT,"[DATE RANGES]")
F I=2:1 S X=$P($T(DTLIST+I),";",3) Q:X=EOF D SETITEM(.ROOT,"d"_X)
Q
DTLIST ; -- list of date ranges
;<number of days>^ <display text>
;;S^Date Range...
;;0^Today
;;7^One Week Back
;;14^Two Weeks Back
;;30^One Month Back
;;180^Six Months Back
;;365^One Year Back
;;732^Two Years Back
;;50000^All Results
;;$$END
;
SETITEM(ROOT,X) ; -- set item in list
S @ROOT@($O(@ROOT@(9999),-1)+1)=X
Q
RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text
;ROOT=Output in ^TMP("ORDATA",$J)
;DFN=Patient DFN ; ICN for remote sites
;RPTID=Unique report ID_";"_Remote ID_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc)
;HSTYPE=Health Sum Type
;DTRANGE=# days back from today
;EXAMID=Rad exam ID
;ALPHA=Start date
;OMEGA=End date
; RPC: ORWRP REPORT TEXT
;
N X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT,TAB
K ^TMP("ORDATA",$J)
S TAB="R"
I $E(RPTID,1,2)="L:" S TAB="L",RPTID=$P(RPTID,":",2,999) ;an ID beginning with "L:" forces TAB to LAB - "L:" added in GUI code
S HSTAG=$P($G(RPTID),"~",2),RPTID=$P($G(RPTID),"~"),ROOT=$NA(^TMP("ORDATA",$J,1)),REMOTE=+$P(RPTID,";",2),RPTID=$P($P(RPTID,";"),":")
I 'REMOTE S DFN=+DFN ;DFN = DFN;ICN for remote calls
S I=0,X0="",X2="",X4="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D
. I $P($G(^ORD(101.24,J,0)),"^",2)=RPTID,$P(^(0),"^",8)=TAB S X0=^(0),X2=$G(^(2)),ORFHIE=$G(^(4)),DIRECT=$P(ORFHIE,"^",4),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3)
I '$L(X0) D NOTYET(.ROOT) Q
S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6)
I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q
I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q
;I $G(ALPHA) S X=ALPHA-$G(OMEGA) D ;jeh 243
I $G(ALPHA) D
. N X1,X2
. S X=ALPHA
. S X1=ALPHA,X2=$G(OMEGA) D:X2 ^%DTC ;X returned, # of days diff
. I X<0 S X=X*(-1)
. I X4,X>X4 S:ALPHA>OMEGA OMEGA=$$FMADD^XLFDT(ALPHA,-X4) S:ALPHA'>OMEGA ALPHA=$$FMADD^XLFDT(OMEGA,-X4) S DTRANGE=""
I X4,$G(DTRANGE)>X4 S DTRANGE=X4,ALPHA=""
I $L($G(DTRANGE)),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-DTRANGE),OMEGA=DT_".235959"
I $G(OMEGA),$E(OMEGA,8)'="." S OMEGA=OMEGA_".235959"
S ID=$G(HSTAG),$P(ID,";",5,10)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)_";"_RPTID_";"_$G(DIRECT) ;HDRHX CHANGE
I $L($P($G(HSTAG),";",4)) S MAX=$P(HSTAG,";",4)
I $L($G(HSTYPE)) M ID=HSTYPE
I $L($G(EXAMID)) M ID=EXAMID
S OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)"
I REMOTE S GO=0 D Q:'GO
. I '$L($T(GETDFN^MPIF001)) D SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")") S GO=0 Q
. S ICN=+$P(DFN,";",2),DFN=+$$GETDFN^MPIF001(ICN)
. I DFN<0 D SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")") S GO=0 Q
. S GO=+$P(X0,"^",3)
. I 'GO D SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")")
. S:'$D(DUZ("AG")) DUZ("AG")="" ;Broker not setting agency for remote sites - IHS/CIA/DKM
. S:'$D(DUZ(2)) DUZ(2)=$P($$SITE^VASITE,"^",3) ;Broker not setting DUZ(2) for remote sites - IHS/CIA/DKM
S %ZIS="0N"
D @OUT
Q
NOTYET(ROOT) ; -- not available
D SETITEM(.ROOT,"Report not available at this time.")
Q
START(RM,GOTO,ORIOSL) ;
;RM=Right margin
N ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS
S ORHFS=$$HFS(),ORSUB="ORDATA",ORHANDLE="ORWRP"
D HFSOPEN(ORHANDLE,ORHFS,"W")
I POP D Q
. I $D(ROOT) D SETITEM(.ROOT,"ERROR: Unable to open HFS file")
D IOVAR(.ORIO,.RM,.ORIOSL)
N $ETRAP,$ESTACK
S $ETRAP="D ERR^ORWRP Q"
U IO
D @GOTO
D HFSCLOSE(ORHANDLE,ORHFS)
Q
ERR ;Error trap
S $ETRAP="D UNWIND^ORWRP Q"
N %ZIS
S %ZIS="0N"
D @^%ZOSF("ERRTN") ;file error
I $D(ORHANDLE) D CLOSE^%ZISH(ORHANDLE)
I $D(ORHFS) D
. N ORARR,OROK
. S ORARR(ORHFS)="",OROK=$$DEL^%ZISH("",$NA(ORARR)) ;delete HFS file
S $ECODE=",UOR69 error during CPRS report build,"
Q
UNWIND ;Unwind Error stack
Q:$ESTACK>1 ;pop stack
;
Q
HFS() ; -- get hfs file name
N H
S H=$H
Q "ORU_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT"
HFSOPEN(HANDLE,ORHFS,ORMODE) ;
D OPEN^%ZISH(HANDLE,,ORHFS,$G(ORMODE,"W")) Q:POP
Q
IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device
N IFN,IFN1
S ORIO=$G(ORIO,"OR WORKSTATION"),ION=ORIO,IOM=$G(ORRM,80),IOSL=$G(ORIOSL,62),IOST=$G(ORIOST,"P-OTHER"),IOF=$G(ORIOF,""""""),IOT=$G(ORIOT,"HFS")
I $O(^%ZIS(1,"B",ORIO,0)) S IFN=$O(^(0)),IOS=IFN
I $D(^%ZIS(1,IFN,0)) S IOST(0)=+$G(^("SUBTYPE")),IOT=$G(ORIOT,^("TYPE")),IOST=$G(ORIOST,$P($G(^%ZIS(2,IOST(0),0),IOST),"^"))
I $O(^%ZIS(2,"B",IOST,0)) S IFN=$O(^(0)) I IFN S IOST(0)=IFN,IFN1=$G(^%ZIS(2,IFN,1)),IOM=$G(ORRM,$P(IFN1,"^")),IOF=$G(ORIOF,$P(IFN1,"^",2)),IOSL=$G(ORIOSL,$P(IFN1,"^",3))
Q
HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data
N ORDEL,X,%ZIS
S %ZIS="0N"
I IO[ORHFS D CLOSE^%ZISH(HANDLE)
S ROOT=$NA(^TMP(ORSUB,$J,1)),ORDEL(ORHFS)=""
K @ROOT
S X=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4)
D STRIP
S X=$$DEL^%ZISH(,$NA(ORDEL))
Q
USEHFS ; -- use host file to build global array
N OROK,SECTION
S SECTION=0
D INIT
S OROK=$$FTG^%ZISH(,ORHFS,$NA(@ROOT@(1)),4) I 'OROK Q
D STRIP
N ORARR S ORARR(ORHFS)=""
S OROK=$$DEL^%ZISH("",$NA(ORARR))
Q
INIT ; -- initialize counts and global section
S (INC,CNT)=0,SECTION=SECTION+1,ROOT=$NA(^TMP(ORSUB,$J,SECTION))
K @ROOT
Q
FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR
N I
F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION
Q
STRIP ; -- strip off control chars
N I,X
S I=0 F S I=$O(@ROOT@(I)) Q:'I S X=^(I) D
. I X[$C(8) D ;BS
.. I $L(X,$C(8))=$L(X,$C(95)) S (X,@ROOT@(I))=$TR(X,$C(8,95),"") Q ;BS & _
.. S (X,@ROOT@(I))=$TR(X,$C(8),"")
. I X[$C(7)!(X[$C(12)) S @ROOT@(I)=$TR(X,$C(7,12),"") ;BEL or FF
Q
WINDFLT(ORY) ;Windows printer as default?
S ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT")
Q
GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user
N IEN,X0,ENT
S ENT="ALL"
I $G(ORLOC) S ORLOC=+ORLOC_";SC(",ENT=ENT_"^"_ORLOC
I +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT") S Y="WIN;Windows Printer" Q
S IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1) Q:+IEN=0
Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0)
S Y=IEN_";"_$P(X0,U)
Q
SAVDFPRT(Y,ORDEV) ; Save new default printer for user
N ORPAR,ORERR,ORWINDEF
Q:$L(ORDEV)=0
; Reset Windows printer default to True/False
S ORPAR="ORWDP WINPRINT DEFAULT"
I ORDEV="WIN" S ORWINDEF="Y"
E S ORWINDEF="N"
I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
Q:ORDEV="WIN"
; If not Windows printer selected, save VistA default printer
S ORPAR="ORWDP DEFAULT PRINTER",ORDEV="`"_ORDEV
I $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'="" D CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
E D ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
Q
ORWRP ; ALB/MJK,dcm Report Calls ;23-Nov-2011 11:55;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,1002,194,227,215,262,243,1010**;Dec 17, 1997;Build 47
+2 ;Modified - IHS/CIA/DKM - 2/27/07 - Line GETHS+15, RPT+45
LABLIST(LST) ; -- report list for labs tab
+1 ; RPC: ORWRP LAB REPORT LIST
+2 NEW I,J,X,X0,X2,CNT,EOF,IFN,ROOT,RPC,ORLIST,HEAD
+3 SET EOF="$$END"
SET ROOT=$NAME(LST)
SET (CNT,I)=0
+4 DO SETITEM(ROOT,"[LAB REPORT LIST]")
+5 DO GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LAB LIST")
+6 FOR
SET I=$ORDER(ORLIST(I))
IF 'I
QUIT
IF '$DATA(^ORD(101.24,$PIECE(ORLIST(I),"^",2),0))
QUIT
SET X0=^(0)
SET X2=$GET(^(2))
Begin DoDot:1
+7 IF $PIECE(X0,"^",12)="L"
QUIT
+8 SET RPC=$$GET1^DIQ(8994,+$PIECE(X0,"^",13),.01)
SET IFN=ORLIST(I)
SET HEAD=$PIECE(X0,"^")
+9 IF $LENGTH($PIECE(X2,"^",3))
SET HEAD=$PIECE(X2,"^",3)
+10 SET X=$PIECE(X0,"^",2)_"^"_HEAD_"^"_$PIECE(X0,"^",3)_"^"_$PIECE(X0,"^",12)_"^"_$PIECE(X0,"^",7)_"^"_RPC_"^"_IFN
+11 DO SETITEM(.ROOT,X)
End DoDot:1
+12 DO SETITEM(.ROOT,"$$END")
+13 QUIT
LIST(LST) ; -- report lists for reports tab
+1 ; RPC: ORWRP REPORT LIST
+2 NEW EOF,ROOT
+3 SET EOF="$$END"
SET ROOT=$NAME(LST)
+4 KILL @ROOT
+5 ; -report list
DO GETRPTS(.ROOT,.EOF)
+6 ; -health summary types
DO GETHS(.ROOT,.EOF)
+7 ; -date ranges
DO GETDT(.ROOT,.EOF)
+8 QUIT
GETCOL(ROOT,IFN) ; -- get Column headers for ListView
+1 NEW I,J,X,VAL
+2 IF '$GET(IFN)
QUIT
+3 SET I=0
SET ROOT=$NAME(ROOT)
+4 FOR
SET I=$ORDER(^ORD(101.24,IFN,3,"C",I))
IF 'I
QUIT
Begin DoDot:1
+5 SET VAL=$$GET^XPAR(DUZ_";VA(200,","ORWCH COLUMNS REPORTS",IFN,"I")
SET J=0
+6 FOR
SET J=$ORDER(^ORD(101.24,IFN,3,"C",I,J))
IF 'J
QUIT
IF $DATA(^ORD(101.24,IFN,3,J))
SET X=^(J,0)
Begin DoDot:2
+7 IF $LENGTH(VAL)
IF $PIECE(VAL,",",I)
SET $PIECE(X,"^",10)=$PIECE(VAL,",",I)
+8 DO SETITEM(.ROOT,X)
End DoDot:2
End DoDot:1
+9 QUIT
GETRPTS(ROOT,EOF) ; -- get report list
+1 NEW I,J,X,X0,X2,CNT,IFN,ORLIST,HEAD
+2 DO SETITEM(.ROOT,"[REPORT LIST]")
DO GETLST^XPAR(.ORLIST,"ALL","ORWRP REPORT LIST")
+3 SET (CNT,I)=0
+4 FOR
SET I=$ORDER(ORLIST(I))
IF 'I
QUIT
IF '$DATA(^ORD(101.24,$PIECE(ORLIST(I),"^",2),0))
QUIT
SET X0=^(0)
SET X2=$GET(^(2))
Begin DoDot:1
+5 IF $PIECE(X0,"^",12)="L"
QUIT
+6 SET RPC=$$GET1^DIQ(8994,+$PIECE(X0,"^",13),.01)
SET IFN=ORLIST(I)
SET HEAD=$PIECE(X0,"^")
+7 IF $LENGTH($PIECE(X2,"^",3))
SET HEAD=$PIECE(X2,"^",3)
+8 SET X=$PIECE(X0,"^",2)_"^"_HEAD_"^"_$PIECE(X0,"^",4)_"^"_$PIECE(X0,"^",19)_";"_$PIECE(X0,"^",20)_"^"_$PIECE(X0,"^",6)_"^"_$PIECE(X0,"^",5)_"^"_$PIECE(X0,"^",3)_"^"_$PIECE(X0,"^",12)_"^"_$PIECE(X0,"^",7)_"^"_RPC_"^"_IFN
+9 DO SETITEM(.ROOT,X)
End DoDot:1
+10 DO SETITEM(.ROOT,"$$END")
+11 QUIT
GETHS(ROOT,EOF) ; --get health summary types
+1 NEW C,I,IFN,ORHSPARM,ORERR,X,T
+2 KILL ^TMP("ORHSPARM",$JOB)
+3 SET ORHSROOT="^TMP(""ORHSPARM"",$J)"
+4 IF $$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1)
SET I=""
SET C=0
Begin DoDot:1
+5 FOR
SET I=$ORDER(^GMT(142,"B",I))
IF I=""
QUIT
SET IFN=$ORDER(^(I,0))
IF 'IFN
QUIT
Begin DoDot:2
+6 SET X=$GET(^GMT(142,IFN,0))
IF '$LENGTH(X)
QUIT
+7 SET T=$GET(^GMT(142,IFN,"T"))
SET C=C+1
SET @ORHSROOT@(C)=IFN_"^"_$SELECT($LENGTH(T):T,1:$PIECE(X,"^"))_"^^^^^1"
+8 IF I="GMTS HS ADHOC OPTION"
SET @ORHSROOT@(C)="0^GMTS Adhoc Report"
End DoDot:2
End DoDot:1
+9 IF '$$GET^XPAR("ALL","ORWRP HEALTH SUMMARY LIST ALL",1)
Begin DoDot:1
+10 IF $LENGTH($TEXT(GETLIST^GMTSXAL))
DO GETLIST^GMTSXAL($NAME(@ORHSROOT),$GET(DUZ),1,.ORERR)
+11 IF $GET(ORERR)
QUIT
+12 SET I=0
FOR
SET I=$ORDER(@ORHSROOT@(I))
IF 'I
QUIT
SET @ORHSROOT@(I)=@ORHSROOT@(I)_"^^^^^1"
IF $PIECE(@ORHSROOT@(I),"^",2)="GMTS HS ADHOC OPTION"
SET @ORHSROOT@(I)="0^Adhoc Report"
End DoDot:1
+13 DO SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
+14 SET I=0
FOR
SET I=$ORDER(@ORHSROOT@(I))
IF 'I
QUIT
DO SETITEM(.ROOT,"h"_@ORHSROOT@(I))
+15 ; IHS/CIA/DKM - Support for IHS health summaries
DO GETHS^ORWRPBHS(.ROOT,.EOF)
+16 DO SETITEM(.ROOT,EOF)
+17 QUIT
GETDT(ROOT,EOF) ; -- get date range choices
+1 NEW I,X
+2 DO SETITEM(.ROOT,"[DATE RANGES]")
+3 FOR I=2:1
SET X=$PIECE($TEXT(DTLIST+I),";",3)
IF X=EOF
QUIT
DO SETITEM(.ROOT,"d"_X)
+4 QUIT
DTLIST ; -- list of date ranges
+1 ;<number of days>^ <display text>
+2 ;;S^Date Range...
+3 ;;0^Today
+4 ;;7^One Week Back
+5 ;;14^Two Weeks Back
+6 ;;30^One Month Back
+7 ;;180^Six Months Back
+8 ;;365^One Year Back
+9 ;;732^Two Years Back
+10 ;;50000^All Results
+11 ;;$$END
+12 ;
SETITEM(ROOT,X) ; -- set item in list
+1 SET @ROOT@($ORDER(@ROOT@(9999),-1)+1)=X
+2 QUIT
RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,EXAMID,ALPHA,OMEGA) ; -- return report text
+1 ;ROOT=Output in ^TMP("ORDATA",$J)
+2 ;DFN=Patient DFN ; ICN for remote sites
+3 ;RPTID=Unique report ID_";"_Remote ID_"~"_HSComponent for listview (ent;rtn;0;MaxOcc) or text (ent;rtn;#component;MaxOcc)
+4 ;HSTYPE=Health Sum Type
+5 ;DTRANGE=# days back from today
+6 ;EXAMID=Rad exam ID
+7 ;ALPHA=Start date
+8 ;OMEGA=End date
+9 ; RPC: ORWRP REPORT TEXT
+10 ;
+11 NEW X,X0,X2,X4,I,J,ENT,RTN,ID,REMOTE,GO,OUT,MAX,SITE,ORFHIE,%ZIS,HSTAG,DIRECT,TAB
+12 KILL ^TMP("ORDATA",$JOB)
+13 SET TAB="R"
+14 ;an ID beginning with "L:" forces TAB to LAB - "L:" added in GUI code
IF $EXTRACT(RPTID,1,2)="L:"
SET TAB="L"
SET RPTID=$PIECE(RPTID,":",2,999)
+15 SET HSTAG=$PIECE($GET(RPTID),"~",2)
SET RPTID=$PIECE($GET(RPTID),"~")
SET ROOT=$NAME(^TMP("ORDATA",$JOB,1))
SET REMOTE=+$PIECE(RPTID,";",2)
SET RPTID=$PIECE($PIECE(RPTID,";"),":")
+16 ;DFN = DFN;ICN for remote calls
IF 'REMOTE
SET DFN=+DFN
+17 SET I=0
SET X0=""
SET X2=""
SET X4=""
SET SITE=$$SITE^VASITE
SET SITE=$PIECE(SITE,"^",2)_";"_$PIECE(SITE,"^",3)
+18 FOR
SET I=$ORDER(^ORD(101.24,"AC",I))
IF I=""
QUIT
SET J=0
FOR
SET J=$ORDER(^ORD(101.24,"AC",I,J))
IF 'J
QUIT
Begin DoDot:1
+19 IF $PIECE($GET(^ORD(101.24,J,0)),"^",2)=RPTID
IF $PIECE(^(0),"^",8)=TAB
SET X0=^(0)
SET X2=$GET(^(2))
SET ORFHIE=$GET(^(4))
SET DIRECT=$PIECE(ORFHIE,"^",4)
SET X4=$PIECE(ORFHIE,"^",2)
SET ORFHIE=$PIECE(ORFHIE,"^",3)
End DoDot:1
+20 IF '$LENGTH(X0)
DO NOTYET(.ROOT)
QUIT
+21 SET RTN=$PIECE(X0,"^",5)
SET ENT=$PIECE(X0,"^",6)
+22 IF '$LENGTH(RTN)!'$LENGTH(ENT)
DO NOTYET(.ROOT)
QUIT
+23 IF '$LENGTH($TEXT(@(ENT_"^"_RTN)))
DO NOTYET(.ROOT)
QUIT
+24 ;I $G(ALPHA) S X=ALPHA-$G(OMEGA) D ;jeh 243
+25 IF $GET(ALPHA)
Begin DoDot:1
+26 NEW X1,X2
+27 SET X=ALPHA
+28 ;X returned, # of days diff
SET X1=ALPHA
SET X2=$GET(OMEGA)
IF X2
DO ^%DTC
+29 IF X<0
SET X=X*(-1)
+30 IF X4
IF X>X4
IF ALPHA>OMEGA
SET OMEGA=$$FMADD^XLFDT(ALPHA,-X4)
IF ALPHA'>OMEGA
SET ALPHA=$$FMADD^XLFDT(OMEGA,-X4)
SET DTRANGE=""
End DoDot:1
+31 IF X4
IF $GET(DTRANGE)>X4
SET DTRANGE=X4
SET ALPHA=""
+32 IF $LENGTH($GET(DTRANGE))
IF '$GET(ALPHA)
SET ALPHA=$$FMADD^XLFDT(DT,-DTRANGE)
SET OMEGA=DT_".235959"
+33 IF $GET(OMEGA)
IF $EXTRACT(OMEGA,8)'="."
SET OMEGA=OMEGA_".235959"
+34 ;HDRHX CHANGE
SET ID=$GET(HSTAG)
SET $PIECE(ID,";",5,10)=SITE_";"_$PIECE(X2,"^",8)_";"_$PIECE(X2,"^",9)_";"_RPTID_";"_$GET(DIRECT)
+35 IF $LENGTH($PIECE($GET(HSTAG),";",4))
SET MAX=$PIECE(HSTAG,";",4)
+36 IF $LENGTH($GET(HSTYPE))
MERGE ID=HSTYPE
+37 IF $LENGTH($GET(EXAMID))
MERGE ID=EXAMID
+38 SET OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)"
+39 IF REMOTE
SET GO=0
Begin DoDot:1
+40 IF '$LENGTH($TEXT(GETDFN^MPIF001))
DO SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")")
SET GO=0
QUIT
+41 SET ICN=+$PIECE(DFN,";",2)
SET DFN=+$$GETDFN^MPIF001(ICN)
+42 IF DFN<0
DO SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")")
SET GO=0
QUIT
+43 SET GO=+$PIECE(X0,"^",3)
+44 IF 'GO
DO SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")")
+45 ;Broker not setting agency for remote sites - IHS/CIA/DKM
IF '$DATA(DUZ("AG"))
SET DUZ("AG")=""
+46 ;Broker not setting DUZ(2) for remote sites - IHS/CIA/DKM
IF '$DATA(DUZ(2))
SET DUZ(2)=$PIECE($$SITE^VASITE,"^",3)
End DoDot:1
IF 'GO
QUIT
+47 SET %ZIS="0N"
+48 DO @OUT
+49 QUIT
NOTYET(ROOT) ; -- not available
+1 DO SETITEM(.ROOT,"Report not available at this time.")
+2 QUIT
START(RM,GOTO,ORIOSL) ;
+1 ;RM=Right margin
+2 NEW ZTQUEUED,ORHFS,ORSUB,ORIO,ORHANDLE,IOM,IOSL,IOST,IOF,IOT,IOS
+3 SET ORHFS=$$HFS()
SET ORSUB="ORDATA"
SET ORHANDLE="ORWRP"
+4 DO HFSOPEN(ORHANDLE,ORHFS,"W")
+5 IF POP
Begin DoDot:1
+6 IF $DATA(ROOT)
DO SETITEM(.ROOT,"ERROR: Unable to open HFS file")
End DoDot:1
QUIT
+7 DO IOVAR(.ORIO,.RM,.ORIOSL)
+8 NEW $ETRAP,$ESTACK
+9 SET $ETRAP="D ERR^ORWRP Q"
+10 USE IO
+11 DO @GOTO
+12 DO HFSCLOSE(ORHANDLE,ORHFS)
+13 QUIT
ERR ;Error trap
+1 SET $ETRAP="D UNWIND^ORWRP Q"
+2 NEW %ZIS
+3 SET %ZIS="0N"
+4 ;file error
DO @^%ZOSF("ERRTN")
+5 IF $DATA(ORHANDLE)
DO CLOSE^%ZISH(ORHANDLE)
+6 IF $DATA(ORHFS)
Begin DoDot:1
+7 NEW ORARR,OROK
+8 ;delete HFS file
SET ORARR(ORHFS)=""
SET OROK=$$DEL^%ZISH("",$NAME(ORARR))
End DoDot:1
+9 SET $ECODE=",UOR69 error during CPRS report build,"
+10 QUIT
UNWIND ;Unwind Error stack
+1 ;pop stack
IF $ESTACK>1
QUIT
+2 ;
+3 QUIT
HFS() ; -- get hfs file name
+1 NEW H
+2 SET H=$HOROLOG
+3 QUIT "ORU_"_$JOB_"_"_$PIECE(H,",")_"_"_$PIECE(H,",",2)_".DAT"
HFSOPEN(HANDLE,ORHFS,ORMODE) ;
+1 DO OPEN^%ZISH(HANDLE,,ORHFS,$GET(ORMODE,"W"))
IF POP
QUIT
+2 QUIT
IOVAR(ORIO,ORRM,ORIOSL,ORIOST,ORIOF,ORIOT) ;Setup IO variables based on IO Device
+1 NEW IFN,IFN1
+2 SET ORIO=$GET(ORIO,"OR WORKSTATION")
SET ION=ORIO
SET IOM=$GET(ORRM,80)
SET IOSL=$GET(ORIOSL,62)
SET IOST=$GET(ORIOST,"P-OTHER")
SET IOF=$GET(ORIOF,"""""")
SET IOT=$GET(ORIOT,"HFS")
+3 IF $ORDER(^%ZIS(1,"B",ORIO,0))
SET IFN=$ORDER(^(0))
SET IOS=IFN
+4 IF $DATA(^%ZIS(1,IFN,0))
SET IOST(0)=+$GET(^("SUBTYPE"))
SET IOT=$GET(ORIOT,^("TYPE"))
SET IOST=$GET(ORIOST,$PIECE($GET(^%ZIS(2,IOST(0),0),IOST),"^"))
+5 IF $ORDER(^%ZIS(2,"B",IOST,0))
SET IFN=$ORDER(^(0))
IF IFN
SET IOST(0)=IFN
SET IFN1=$GET(^%ZIS(2,IFN,1))
SET IOM=$GET(ORRM,$PIECE(IFN1,"^"))
SET IOF=$GET(ORIOF,$PIECE(IFN1,"^",2))
SET IOSL=$GET(ORIOSL,$PIECE(IFN1,"^",3))
+6 QUIT
HFSCLOSE(HANDLE,ORHFS) ;Close HFS and unload data
+1 NEW ORDEL,X,%ZIS
+2 SET %ZIS="0N"
+3 IF IO[ORHFS
DO CLOSE^%ZISH(HANDLE)
+4 SET ROOT=$NAME(^TMP(ORSUB,$JOB,1))
SET ORDEL(ORHFS)=""
+5 KILL @ROOT
+6 SET X=$$FTG^%ZISH(,ORHFS,$NAME(@ROOT@(1)),4)
+7 DO STRIP
+8 SET X=$$DEL^%ZISH(,$NAME(ORDEL))
+9 QUIT
USEHFS ; -- use host file to build global array
+1 NEW OROK,SECTION
+2 SET SECTION=0
+3 DO INIT
+4 SET OROK=$$FTG^%ZISH(,ORHFS,$NAME(@ROOT@(1)),4)
IF 'OROK
QUIT
+5 DO STRIP
+6 NEW ORARR
SET ORARR(ORHFS)=""
+7 SET OROK=$$DEL^%ZISH("",$NAME(ORARR))
+8 QUIT
INIT ; -- initialize counts and global section
+1 SET (INC,CNT)=0
SET SECTION=SECTION+1
SET ROOT=$NAME(^TMP(ORSUB,$JOB,SECTION))
+2 KILL @ROOT
+3 QUIT
FINAL ; -- set 'x of y' for each section CALLED FROM ^ORWLR
+1 NEW I
+2 FOR I=1:1:SECTION
SET ^TMP(ORSUB,$JOB,I,.1)=I_U_SECTION
+3 QUIT
STRIP ; -- strip off control chars
+1 NEW I,X
+2 SET I=0
FOR
SET I=$ORDER(@ROOT@(I))
IF 'I
QUIT
SET X=^(I)
Begin DoDot:1
+3 ;BS
IF X[$CHAR(8)
Begin DoDot:2
+4 ;BS & _
IF $LENGTH(X,$CHAR(8))=$LENGTH(X,$CHAR(95))
SET (X,@ROOT@(I))=$TRANSLATE(X,$CHAR(8,95),"")
QUIT
+5 SET (X,@ROOT@(I))=$TRANSLATE(X,$CHAR(8),"")
End DoDot:2
+6 ;BEL or FF
IF X[$CHAR(7)!(X[$CHAR(12))
SET @ROOT@(I)=$TRANSLATE(X,$CHAR(7,12),"")
End DoDot:1
+7 QUIT
WINDFLT(ORY) ;Windows printer as default?
+1 SET ORY=+$$GET^XPAR("ALL","ORWDP WINPRINT DEFAULT")
+2 QUIT
GETDFPRT(Y,ORUSER,ORLOC) ; Returns default printer for user
+1 NEW IEN,X0,ENT
+2 SET ENT="ALL"
+3 IF $GET(ORLOC)
SET ORLOC=+ORLOC_";SC("
SET ENT=ENT_"^"_ORLOC
+4 IF +$$GET^XPAR(ENT,"ORWDP WINPRINT DEFAULT")
SET Y="WIN;Windows Printer"
QUIT
+5 SET IEN=$$GET^XPAR(ENT,"ORWDP DEFAULT PRINTER",1)
IF +IEN=0
QUIT
+6 IF '$DATA(^%ZIS(1,IEN,0))
QUIT
SET X0=^(0)
+7 SET Y=IEN_";"_$PIECE(X0,U)
+8 QUIT
SAVDFPRT(Y,ORDEV) ; Save new default printer for user
+1 NEW ORPAR,ORERR,ORWINDEF
+2 IF $LENGTH(ORDEV)=0
QUIT
+3 ; Reset Windows printer default to True/False
+4 SET ORPAR="ORWDP WINPRINT DEFAULT"
+5 IF ORDEV="WIN"
SET ORWINDEF="Y"
+6 IF '$TEST
SET ORWINDEF="N"
+7 IF $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'=""
DO CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
+8 IF '$TEST
DO ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORWINDEF,.ORERR)
+9 IF ORDEV="WIN"
QUIT
+10 ; If not Windows printer selected, save VistA default printer
+11 SET ORPAR="ORWDP DEFAULT PRINTER"
SET ORDEV="`"_ORDEV
+12 IF $$GET^XPAR(DUZ_";VA(200,",ORPAR,1)'=""
DO CHG^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
+13 IF '$TEST
DO ADD^XPAR(DUZ_";VA(200,",ORPAR,1,ORDEV,.ORERR)
+14 QUIT
