ORWRP16 ; ALB/MJK Report Calls - 16bit ;5/22/97 19:13
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
;
LIST(ROOT) ; -- return lists for list boxes
; RPC: ORWRP REPORT LIST
; See RPC definition for details on input and output parameters
;
N EOF
S EOF="$$END",ROOT=$NA(^TMP($J,"ORPTLIST"))
K @ROOT
;
; -- get list of reports
D GETRPTS(.ROOT,.EOF)
; -- get list of health summary types
D GETHS(.ROOT,.EOF)
; -- get list of date ranges
D GETDT(.ROOT,.EOF)
;
Q
;
GETRPTS(ROOT,EOF) ; -- get list of reports
N I,X
D SETITEM(.ROOT,"[REPORT LIST]")
F I=2:1 S X=$P($T(RPTLIST+I),";",3) D SETITEM(.ROOT,X) Q:X=EOF
Q
;
RPTLIST ; -- list of reports
;<ID> ^ <report name> ^ <ask date range> ^ <ask health summary type> ^ <right margin>
;;1^Health Summary^N^Y^80
;;2^Blood Bank Report^N^N^80
;;3^Anatomic Path Report^N^N^80
;;4^Dietetics Profile^N^N^80
;;5^Vitals Cumulative^Y^N^132
;;6^Vitals SF511^Y^N^132
;;$$END
;
GETHS(ROOT,EOF) ; --get list of health summary types
N I,HSPARM
D GETLST^XPAR(.HSPARM,"SYS","ORWRP HEALTH SUMMARY TYPE LIST","N")
;
D SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
S I=0 F S I=$O(HSPARM(I)) Q:'I D SETITEM(.ROOT,HSPARM(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) D SETITEM(.ROOT,X) Q:X=EOF
Q
;
DTLIST ; -- list of date ranges
;<number of days>^ <display text>
;;0^Today
;;7^One Week Back
;;14^Two Weeks Back
;;30^One Month Back
;;180^Six Months Back
;;365^One Year Back
;;$$END
;
SETITEM(ROOT,X) ; -- set item in list
S @ROOT@($O(@ROOT@(9999),-1)+1)=X
Q
;
RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,SECTION) ; -- return report text
; RPC: ORWRP REPORT TEXT
; See RPC definition for details on input and output parameters
;
IF $G(SECTION),$D(^TMP("ORDATA",$J,SECTION)) D G RPTQ
. S ROOT=$NA(^TMP("ORDATA",$J,SECTION))
;
; -- init output global for close logic of WORKSTATION device
K ^TMP("ORDATA",$J)
S ROOT=$NA(^TMP("ORDATA",$J,1))
;
; -- get report text
IF RPTID=1 D HS(DFN,HSTYPE) G RPTQ
IF RPTID=2 D BL(DFN) G RPTQ
IF RPTID=3 D PATH(DFN) G RPTQ
IF RPTID=4 D DIET(.ROOT,DFN) G RPTQ
IF RPTID=5 D VITALS(DFN,DTRANGE,"VITCUM") G RPTQ
IF RPTID=6 D VITALS(DFN,DTRANGE,"VIT511") G RPTQ
;
; -- basic report if id not found above
D NOTYET(.ROOT)
RPTQ Q
;
HS(ORDFN,ORHS) ; - get health summary report
N ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
S ORRM=80,ORHFS=$$HFS(),ORSUB="ORDATA"
D OPEN(.ORRM,.ORHFS,"W",.ORIO)
;
D HSB(.ORDFN,.ORHS)
;
D CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
Q
;
HSB(ORDFN,ORHS) ; - build health summary report
N ORVP,GMTYP,Y
S ORVP=ORDFN_";DPT("
S Y=$P($G(^GMT(142,+ORHS,0)),U)
S GMTYP(0)=1,GMTYP(1)=+ORHS_U_Y_U_Y_U_Y
D PQ^ORPRS13
Q
;
BL(ORDFN) ; -- get blood bank report
N ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
S ORRM=80,ORHFS=$$HFS(),ORSUB="ORDATA"
D OPEN(.ORRM,.ORHFS,"W",.ORIO)
;
D BLB(.ORDFN)
;
D CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
Q
;
BLB(ORDFN) ; -- build blood bank report
N DFN
;
D SET^LRBLPD1
IF $G(OREND)'=1 D
. S DFN=ORDFN
. D OERR^LRBLPD1
. D CLEAN^LRBLPD1
Q
;
PATH(ORDFN) ; -- get anatomic path report
N ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
S ORRM=80,ORHFS=$$HFS(),ORSUB="ORDATA"
D OPEN(.ORRM,.ORHFS,"W",.ORIO)
;
D PATHB(.ORDFN)
;
D CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
Q
;
PATHB(ORDFN) ; -- build anatomic path report
N DFN
;
D SET^LRAPS3
IF $G(OREND)'=1 D
. S DFN=ORDFN
. D OERR^LRAPS3
. D CLEAN^LRAPS3
Q
;
DIET(ROOT,DFN) ; -- get dietetics profile
D NOTYET(.ROOT)
Q
;
DIETB(DFN) ; -- get dietetics profile
W !!,"Dietetics Profile not yet available."
Q
;
VITALS(DFN,DTRANGE,ORTAG) ; -- get vitals report
N ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
S ORRM=132,ORHFS=$$HFS(),ORSUB="ORDATA"
D OPEN(.ORRM,.ORHFS,"W",.ORIO)
;
D VITALSB(.DFN,.DTRANGE,.ORTAG)
;
D CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
Q
;
VITALSB(DFN,DTRANGE,ORTAG) ; -- build vitals report
N ORVP,XQORNOD,ORSSTRT,ORSSTOP
;
S ORVP=DFN_";DPT(",XQORNOD=1
S X1=DT
; -- if TODAY then do not substract 1
S X2=-$S(DTRANGE:DTRANGE-1,1:0)
D C^%DTC
S ORSSTRT(XQORNOD)=X-.7641,ORSSTOP(XQORNOD)=DT+.2359
D @ORTAG^ORPRS14
Q
;
NOTYET(ROOT) ; -- standard not available display text
D SETITEM(.ROOT,"Report not available at this time.")
S @ROOT@(.1)="1^1"
Q
;
HFS() ; -- get hfs file name
; -- need to define better unique algorithm
Q "ORU_"_$J_".DAT"
;
OPEN(ORRM,ORHFS,ORMODE,ORIO) ; -- open WORKSTATION device
; ORRM: right margin
; ORHFS: host file name
; ORMODE: open file in 'R'ead or 'W'rite mode
S ZTQUEUED="" K IOPAR
S IOP="WORKSTATION;"_$G(ORRM,80)
S %ZIS("HFSMODE")=ORMODE,%ZIS("HFSNAME")=ORHFS
D ^%ZIS K IOP,%ZIS
U IO S ORIO=IO
Q
;
CLOSE(ORRM,ORHFS,ORSUB,ORIO) ; -- close WORKSTATION device
; ORSUB: unique subscript name for output
IF IO=ORIO D ^%ZISC
U IO
D USEHFS
U IO
Q
USEHFS ; -- use host file to build global array
N IO,OROK
; D OPEN^%ZISH(ORSUB,"",ORHFS,"R") I POP Q
K ^TMP($J,"ORTMPLST")
S OROK=$$FTG^%ZISH(,ORHFS,$NA(^TMP($J,"ORTMPLST",1)),3)
D BUILD
K ^TMP($J,"ORTMPLST")
; D CLOSE^%ZISH(ORSUB)
N ORARR S ORARR(ORHFS)=""
S OROK=$$DEL^%ZISH("",$NA(ORARR))
Q
;
BUILD ; -- build tmp global for report
N INC,CNT,MAX,SECTION,ROOT,STRIP,LN
S SECTION=0,MAX=20000,STRIP=$C(7,12)
D INIT
; -- strip out ff's and quit on error
S LN=0 F S LN=$O(^TMP($J,"ORTMPLST",LN)) Q:'LN S X=^(LN) D
. ;F U IO R X:5 D Q:$$STATUS^%ZISH
. I (CNT+250)>MAX D INIT
. S X=$TR(X,STRIP,"")
. S INC=INC+1,@ROOT@(INC)=X
. S CNT=CNT+$L(X)
D FINAL
Q
;
INIT ; -- initialize counts and global section
S (INC,CNT)=0,SECTION=SECTION+1
S ROOT=$NA(^TMP(ORSUB,$J,SECTION))
K @ROOT
Q
;
FINAL ; -- set 'x of y' for each section
N I
F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRP16 5968 printed Dec 13, 2024@02:37:18 Page 2
ORWRP16 ; ALB/MJK Report Calls - 16bit ;5/22/97 19:13
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
+2 ;
LIST(ROOT) ; -- return lists for list boxes
+1 ; RPC: ORWRP REPORT LIST
+2 ; See RPC definition for details on input and output parameters
+3 ;
+4 NEW EOF
+5 SET EOF="$$END"
SET ROOT=$NAME(^TMP($JOB,"ORPTLIST"))
+6 KILL @ROOT
+7 ;
+8 ; -- get list of reports
+9 DO GETRPTS(.ROOT,.EOF)
+10 ; -- get list of health summary types
+11 DO GETHS(.ROOT,.EOF)
+12 ; -- get list of date ranges
+13 DO GETDT(.ROOT,.EOF)
+14 ;
+15 QUIT
+16 ;
GETRPTS(ROOT,EOF) ; -- get list of reports
+1 NEW I,X
+2 DO SETITEM(.ROOT,"[REPORT LIST]")
+3 FOR I=2:1
SET X=$PIECE($TEXT(RPTLIST+I),";",3)
DO SETITEM(.ROOT,X)
if X=EOF
QUIT
+4 QUIT
+5 ;
RPTLIST ; -- list of reports
+1 ;<ID> ^ <report name> ^ <ask date range> ^ <ask health summary type> ^ <right margin>
+2 ;;1^Health Summary^N^Y^80
+3 ;;2^Blood Bank Report^N^N^80
+4 ;;3^Anatomic Path Report^N^N^80
+5 ;;4^Dietetics Profile^N^N^80
+6 ;;5^Vitals Cumulative^Y^N^132
+7 ;;6^Vitals SF511^Y^N^132
+8 ;;$$END
+9 ;
GETHS(ROOT,EOF) ; --get list of health summary types
+1 NEW I,HSPARM
+2 DO GETLST^XPAR(.HSPARM,"SYS","ORWRP HEALTH SUMMARY TYPE LIST","N")
+3 ;
+4 DO SETITEM(.ROOT,"[HEALTH SUMMARY TYPES]")
+5 SET I=0
FOR
SET I=$ORDER(HSPARM(I))
if 'I
QUIT
DO SETITEM(.ROOT,HSPARM(I))
+6 DO SETITEM(.ROOT,EOF)
+7 QUIT
+8 ;
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)
DO SETITEM(.ROOT,X)
if X=EOF
QUIT
+4 QUIT
+5 ;
DTLIST ; -- list of date ranges
+1 ;<number of days>^ <display text>
+2 ;;0^Today
+3 ;;7^One Week Back
+4 ;;14^Two Weeks Back
+5 ;;30^One Month Back
+6 ;;180^Six Months Back
+7 ;;365^One Year Back
+8 ;;$$END
+9 ;
SETITEM(ROOT,X) ; -- set item in list
+1 SET @ROOT@($ORDER(@ROOT@(9999),-1)+1)=X
+2 QUIT
+3 ;
RPT(ROOT,DFN,RPTID,HSTYPE,DTRANGE,SECTION) ; -- return report text
+1 ; RPC: ORWRP REPORT TEXT
+2 ; See RPC definition for details on input and output parameters
+3 ;
+4 IF $GET(SECTION)
IF $DATA(^TMP("ORDATA",$JOB,SECTION))
Begin DoDot:1
+5 SET ROOT=$NAME(^TMP("ORDATA",$JOB,SECTION))
End DoDot:1
GOTO RPTQ
+6 ;
+7 ; -- init output global for close logic of WORKSTATION device
+8 KILL ^TMP("ORDATA",$JOB)
+9 SET ROOT=$NAME(^TMP("ORDATA",$JOB,1))
+10 ;
+11 ; -- get report text
+12 IF RPTID=1
DO HS(DFN,HSTYPE)
GOTO RPTQ
+13 IF RPTID=2
DO BL(DFN)
GOTO RPTQ
+14 IF RPTID=3
DO PATH(DFN)
GOTO RPTQ
+15 IF RPTID=4
DO DIET(.ROOT,DFN)
GOTO RPTQ
+16 IF RPTID=5
DO VITALS(DFN,DTRANGE,"VITCUM")
GOTO RPTQ
+17 IF RPTID=6
DO VITALS(DFN,DTRANGE,"VIT511")
GOTO RPTQ
+18 ;
+19 ; -- basic report if id not found above
+20 DO NOTYET(.ROOT)
RPTQ QUIT
+1 ;
HS(ORDFN,ORHS) ; - get health summary report
+1 NEW ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
+2 SET ORRM=80
SET ORHFS=$$HFS()
SET ORSUB="ORDATA"
+3 DO OPEN(.ORRM,.ORHFS,"W",.ORIO)
+4 ;
+5 DO HSB(.ORDFN,.ORHS)
+6 ;
+7 DO CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
+8 QUIT
+9 ;
HSB(ORDFN,ORHS) ; - build health summary report
+1 NEW ORVP,GMTYP,Y
+2 SET ORVP=ORDFN_";DPT("
+3 SET Y=$PIECE($GET(^GMT(142,+ORHS,0)),U)
+4 SET GMTYP(0)=1
SET GMTYP(1)=+ORHS_U_Y_U_Y_U_Y
+5 DO PQ^ORPRS13
+6 QUIT
+7 ;
BL(ORDFN) ; -- get blood bank report
+1 NEW ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
+2 SET ORRM=80
SET ORHFS=$$HFS()
SET ORSUB="ORDATA"
+3 DO OPEN(.ORRM,.ORHFS,"W",.ORIO)
+4 ;
+5 DO BLB(.ORDFN)
+6 ;
+7 DO CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
+8 QUIT
+9 ;
BLB(ORDFN) ; -- build blood bank report
+1 NEW DFN
+2 ;
+3 DO SET^LRBLPD1
+4 IF $GET(OREND)'=1
Begin DoDot:1
+5 SET DFN=ORDFN
+6 DO OERR^LRBLPD1
+7 DO CLEAN^LRBLPD1
End DoDot:1
+8 QUIT
+9 ;
PATH(ORDFN) ; -- get anatomic path report
+1 NEW ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
+2 SET ORRM=80
SET ORHFS=$$HFS()
SET ORSUB="ORDATA"
+3 DO OPEN(.ORRM,.ORHFS,"W",.ORIO)
+4 ;
+5 DO PATHB(.ORDFN)
+6 ;
+7 DO CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
+8 QUIT
+9 ;
PATHB(ORDFN) ; -- build anatomic path report
+1 NEW DFN
+2 ;
+3 DO SET^LRAPS3
+4 IF $GET(OREND)'=1
Begin DoDot:1
+5 SET DFN=ORDFN
+6 DO OERR^LRAPS3
+7 DO CLEAN^LRAPS3
End DoDot:1
+8 QUIT
+9 ;
DIET(ROOT,DFN) ; -- get dietetics profile
+1 DO NOTYET(.ROOT)
+2 QUIT
+3 ;
DIETB(DFN) ; -- get dietetics profile
+1 WRITE !!,"Dietetics Profile not yet available."
+2 QUIT
+3 ;
VITALS(DFN,DTRANGE,ORTAG) ; -- get vitals report
+1 NEW ZTQUEUED,ORRM,ORHFS,ORSUB,ORIO
+2 SET ORRM=132
SET ORHFS=$$HFS()
SET ORSUB="ORDATA"
+3 DO OPEN(.ORRM,.ORHFS,"W",.ORIO)
+4 ;
+5 DO VITALSB(.DFN,.DTRANGE,.ORTAG)
+6 ;
+7 DO CLOSE(.ORRM,.ORHFS,.ORSUB,.ORIO)
+8 QUIT
+9 ;
VITALSB(DFN,DTRANGE,ORTAG) ; -- build vitals report
+1 NEW ORVP,XQORNOD,ORSSTRT,ORSSTOP
+2 ;
+3 SET ORVP=DFN_";DPT("
SET XQORNOD=1
+4 SET X1=DT
+5 ; -- if TODAY then do not substract 1
+6 SET X2=-$SELECT(DTRANGE:DTRANGE-1,1:0)
+7 DO C^%DTC
+8 SET ORSSTRT(XQORNOD)=X-.7641
SET ORSSTOP(XQORNOD)=DT+.2359
+9 DO @ORTAG^ORPRS14
+10 QUIT
+11 ;
NOTYET(ROOT) ; -- standard not available display text
+1 DO SETITEM(.ROOT,"Report not available at this time.")
+2 SET @ROOT@(.1)="1^1"
+3 QUIT
+4 ;
HFS() ; -- get hfs file name
+1 ; -- need to define better unique algorithm
+2 QUIT "ORU_"_$JOB_".DAT"
+3 ;
OPEN(ORRM,ORHFS,ORMODE,ORIO) ; -- open WORKSTATION device
+1 ; ORRM: right margin
+2 ; ORHFS: host file name
+3 ; ORMODE: open file in 'R'ead or 'W'rite mode
+4 SET ZTQUEUED=""
KILL IOPAR
+5 SET IOP="WORKSTATION;"_$GET(ORRM,80)
+6 SET %ZIS("HFSMODE")=ORMODE
SET %ZIS("HFSNAME")=ORHFS
+7 DO ^%ZIS
KILL IOP,%ZIS
+8 USE IO
SET ORIO=IO
+9 QUIT
+10 ;
CLOSE(ORRM,ORHFS,ORSUB,ORIO) ; -- close WORKSTATION device
+1 ; ORSUB: unique subscript name for output
+2 IF IO=ORIO
DO ^%ZISC
+3 USE IO
+4 DO USEHFS
+5 USE IO
+6 QUIT
USEHFS ; -- use host file to build global array
+1 NEW IO,OROK
+2 ; D OPEN^%ZISH(ORSUB,"",ORHFS,"R") I POP Q
+3 KILL ^TMP($JOB,"ORTMPLST")
+4 SET OROK=$$FTG^%ZISH(,ORHFS,$NAME(^TMP($JOB,"ORTMPLST",1)),3)
+5 DO BUILD
+6 KILL ^TMP($JOB,"ORTMPLST")
+7 ; D CLOSE^%ZISH(ORSUB)
+8 NEW ORARR
SET ORARR(ORHFS)=""
+9 SET OROK=$$DEL^%ZISH("",$NAME(ORARR))
+10 QUIT
+11 ;
BUILD ; -- build tmp global for report
+1 NEW INC,CNT,MAX,SECTION,ROOT,STRIP,LN
+2 SET SECTION=0
SET MAX=20000
SET STRIP=$CHAR(7,12)
+3 DO INIT
+4 ; -- strip out ff's and quit on error
+5 SET LN=0
FOR
SET LN=$ORDER(^TMP($JOB,"ORTMPLST",LN))
if 'LN
QUIT
SET X=^(LN)
Begin DoDot:1
+6 ;F U IO R X:5 D Q:$$STATUS^%ZISH
+7 IF (CNT+250)>MAX
DO INIT
+8 SET X=$TRANSLATE(X,STRIP,"")
+9 SET INC=INC+1
SET @ROOT@(INC)=X
+10 SET CNT=CNT+$LENGTH(X)
End DoDot:1
+11 DO FINAL
+12 QUIT
+13 ;
INIT ; -- initialize counts and global section
+1 SET (INC,CNT)=0
SET SECTION=SECTION+1
+2 SET ROOT=$NAME(^TMP(ORSUB,$JOB,SECTION))
+3 KILL @ROOT
+4 QUIT
+5 ;
FINAL ; -- set 'x of y' for each section
+1 NEW I
+2 FOR I=1:1:SECTION
SET ^TMP(ORSUB,$JOB,I,.1)=I_U_SECTION
+3 QUIT
+4 ;
