- ORWRP ; ALB/MJK,dcm Report Calls ;Sep 15, 2020@09:01:07
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262,243,280,377,498**;Dec 17, 1997;Build 38
- ;
- 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,ORHSROOT,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 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
- ;;30^One Month
- ;;180^Six Months
- ;;365^One Year
- ;;732^Two Year
- ;;40000^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,ORRPTIEN,ORTIMOCC
- 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,";"),":")
- S ORRPTIEN=""
- 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(^ORD(101.24,J,0),"^",8)=TAB D
- . . S X0=^ORD(101.24,J,0)
- . . S X2=$G(^ORD(101.24,J,2))
- . . S ORFHIE=$G(^ORD(101.24,J,4))
- . . S DIRECT=$P(ORFHIE,"^",4)
- . . S X4=$P(ORFHIE,"^",2)
- . . S ORFHIE=$P(ORFHIE,"^",3)
- . . S ORRPTIEN=J
- 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)
- ; If HSWPComponent type report, and Max not passed in from GUI, use Max defined in params (GETINDV^ORWTPD)
- ; (temp p498 fix - until can be fixed properly in v32)
- I $P(X0,U,4)=6,$G(MAX)'>0 D
- . I 'ORRPTIEN Q
- . S ORTIMOCC=""
- . D GETINDV^ORWTPD(.ORTIMOCC,ORRPTIEN)
- . I $P(ORTIMOCC,";",3)>0 S MAX=$P(ORTIMOCC,";",3)
- 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 %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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRP 10322 printed Jan 18, 2025@03:38:24 Page 2
- ORWRP ; ALB/MJK,dcm Report Calls ;Sep 15, 2020@09:01:07
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**1,10,85,109,132,160,194,227,215,262,243,280,377,498**;Dec 17, 1997;Build 38
- +2 ;
- 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,ORHSROOT,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 DO SETITEM(.ROOT,EOF)
- +16 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
- +5 ;;30^One Month
- +6 ;;180^Six Months
- +7 ;;365^One Year
- +8 ;;732^Two Year
- +9 ;;40000^All Results
- +10 ;;$$END
- +11 ;
- 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,ORRPTIEN,ORTIMOCC
- +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 SET ORRPTIEN=""
- +17 ;DFN = DFN;ICN for remote calls
- IF 'REMOTE
- SET DFN=+DFN
- +18 SET I=0
- SET X0=""
- SET X2=""
- SET X4=""
- SET SITE=$$SITE^VASITE
- SET SITE=$PIECE(SITE,"^",2)_";"_$PIECE(SITE,"^",3)
- +19 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
- +20 IF $PIECE($GET(^ORD(101.24,J,0)),"^",2)=RPTID
- IF $PIECE(^ORD(101.24,J,0),"^",8)=TAB
- Begin DoDot:2
- +21 SET X0=^ORD(101.24,J,0)
- +22 SET X2=$GET(^ORD(101.24,J,2))
- +23 SET ORFHIE=$GET(^ORD(101.24,J,4))
- +24 SET DIRECT=$PIECE(ORFHIE,"^",4)
- +25 SET X4=$PIECE(ORFHIE,"^",2)
- +26 SET ORFHIE=$PIECE(ORFHIE,"^",3)
- +27 SET ORRPTIEN=J
- End DoDot:2
- End DoDot:1
- +28 IF '$LENGTH(X0)
- DO NOTYET(.ROOT)
- QUIT
- +29 SET RTN=$PIECE(X0,"^",5)
- SET ENT=$PIECE(X0,"^",6)
- +30 IF '$LENGTH(RTN)!'$LENGTH(ENT)
- DO NOTYET(.ROOT)
- QUIT
- +31 IF '$LENGTH($TEXT(@(ENT_"^"_RTN)))
- DO NOTYET(.ROOT)
- QUIT
- +32 ;I $G(ALPHA) S X=ALPHA-$G(OMEGA) D ;jeh 243
- +33 IF $GET(ALPHA)
- Begin DoDot:1
- +34 NEW X1,X2
- +35 SET X=ALPHA
- +36 ;X returned, # of days diff
- SET X1=ALPHA
- SET X2=$GET(OMEGA)
- if X2
- DO ^%DTC
- +37 IF X<0
- SET X=X*(-1)
- +38 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
- +39 IF X4
- IF $GET(DTRANGE)>X4
- SET DTRANGE=X4
- SET ALPHA=""
- +40 IF $LENGTH($GET(DTRANGE))
- IF '$GET(ALPHA)
- SET ALPHA=$$FMADD^XLFDT(DT,-DTRANGE)
- SET OMEGA=DT_".235959"
- +41 IF $GET(OMEGA)
- IF $EXTRACT(OMEGA,8)'="."
- SET OMEGA=OMEGA_".235959"
- +42 ;HDRHX CHANGE
- SET ID=$GET(HSTAG)
- SET $PIECE(ID,";",5,10)=SITE_";"_$PIECE(X2,"^",8)_";"_$PIECE(X2,"^",9)_";"_RPTID_";"_$GET(DIRECT)
- +43 IF $LENGTH($PIECE($GET(HSTAG),";",4))
- SET MAX=$PIECE(HSTAG,";",4)
- +44 ; If HSWPComponent type report, and Max not passed in from GUI, use Max defined in params (GETINDV^ORWTPD)
- +45 ; (temp p498 fix - until can be fixed properly in v32)
- +46 IF $PIECE(X0,U,4)=6
- IF $GET(MAX)'>0
- Begin DoDot:1
- +47 IF 'ORRPTIEN
- QUIT
- +48 SET ORTIMOCC=""
- +49 DO GETINDV^ORWTPD(.ORTIMOCC,ORRPTIEN)
- +50 IF $PIECE(ORTIMOCC,";",3)>0
- SET MAX=$PIECE(ORTIMOCC,";",3)
- End DoDot:1
- +51 IF $LENGTH($GET(HSTYPE))
- MERGE ID=HSTYPE
- +52 IF $LENGTH($GET(EXAMID))
- MERGE ID=EXAMID
- +53 SET OUT=ENT_"^"_RTN_"(.ROOT,DFN,.ID,.ALPHA,.OMEGA,.DTRANGE,.REMOTE,.MAX,.ORFHIE)"
- +54 IF REMOTE
- SET GO=0
- Begin DoDot:1
- +55 IF '$LENGTH($TEXT(GETDFN^MPIF001))
- DO SETITEM(.ROOT,"MPI routines missing on remote system ("_SITE_")")
- SET GO=0
- QUIT
- +56 SET ICN=+$PIECE(DFN,";",2)
- SET DFN=+$$GETDFN^MPIF001(ICN)
- +57 IF DFN<0
- DO SETITEM(.ROOT,"Patient not found on remote system ("_SITE_")")
- SET GO=0
- QUIT
- +58 SET GO=+$PIECE(X0,"^",3)
- +59 IF 'GO
- DO SETITEM(.ROOT,"Remote access not available for this report ("_SITE_")")
- End DoDot:1
- if 'GO
- QUIT
- +60 SET %ZIS="0N"
- +61 DO @OUT
- +62 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