Routine: ORWRP16

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)

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

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)

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

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

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)

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

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)

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

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)

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

DIET(ROOT,DFN) ; -- get dietetics profile

 D NOTYET(.ROOT)

DIETB(DFN) ; -- get dietetics profile

 W !!,"Dietetics Profile not yet available."

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)

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

NOTYET(ROOT) ; -- standard not available display text

 D SETITEM(.ROOT,"Report not available at this time.")

 S @ROOT@(.1)="1^1"

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

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

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))

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

INIT ; -- initialize counts and global section

 S (INC,CNT)=0,SECTION=SECTION+1

 S ROOT=$NA(^TMP(ORSUB,$J,SECTION))

 K @ROOT

FINAL ; -- set 'x of y' for each section

N I

 F I=1:1:SECTION S ^TMP(ORSUB,$J,I,.1)=I_U_SECTION

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRP16   5968     printed  Mar 13, 2025@21:42:17                                                                                                                                                                                                     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       ;

ORWRP16.m