Routine: BLRSHDRC

BLRSHDRC ; IHS/OIT/MKK - NON MICRO STATE HEALTH DEPT REPORT MAIN [ 07/22/2005 ]

 ;;5.2;LR;**1020,1022**;September 20, 2007

;;

 ; Lab PSG gave permission to retrieve programs from PIMC and distribute

 ; nationally.  The original routines at PIMC are BZXLRSER and BZXLRSEP.

 ; Note that ^BLRSHDRD is the new global name for the new dictionary that

 ; this routine depends upon:  REPORTABLE LAB TESTS (# 90475)

 ; It has been distributed with this patch and number given to it by

 ; the IHS DBA.

 ; This is the driver and compiler of data.

 ; It calls BLRSHDRP as the routine to do the actual printing

 ; The following is code to prevent routine from being run by D ^BLRLRSER.

EP ;

 W !,$C(7),$C(7),$C(7),!          ; Bell/Beep

 W "Run from Label ONLY",!!       ; Failsafe code

PEP      ; EP -- Private

 NEW HEADER1,HEADER2,HEADERS

 NEW STR,SITENAME,SITEADDR,SITECITY,SITESTPT,SITESTAB,SITESTNM,SITEZIP

 I $G(IOM)="" D HOME^%ZIS         ; If no IOM, then setup Interactive IO vars

 K ^TMP($J)                       ; Clean up

 D GETSITE                        ; Get site information

 D ^XBCLS                         ; Clear screen and home cursor

 D EN^DDIOL(.HEADERS)             ; Write the Screen Header Lines

 D ^XBFMK                         ; Clear FileMan variables

 S DIR("A")="Enter start date"

 S DIR(0)="D^::EPX"

 D ^DIR

 I $D(DIRUT) D  Q                 ; If ^, or RETURN, or timed out, Quit

 . K DIR,DIRUT,DTOUT,DUOUT

 S BLRSDT=Y                       ; Start Date

 S BLRVDT=Y-.5                    ; Trick for $Order function -- see LP label

GETEND ;

 S DIR("A")="Enter end date"

 S DIR(0)="D^::EPX"

 D ^DIR

 I $D(DIRUT) D  Q

 . K DIR,DIRUT,DTOUT,DUOUT,BLRSDT,BLRVDT

 S BLRENDT=Y

 I BLRENDT<BLRVDT D  G GETEND

 . W !,"End date cannot be before start date.  Try again."

 D ^XBCLS

 D EN^DDIOL(.HEADERS)

 D WAIT^DICD                      ; Wait Message

LP ;Start looping through tests

 ; BLRVDT is both the verification date and the order date

 ; In effect we only look at the verification date

 NEW TMPIT              ; Temp variable -- Discar

 F  S BLRVDT=$O(^LRO(69,BLRVDT)) Q:'BLRVDT!(BLRVDT>BLRENDT)  D

 .S LOC=""

 .F  S LOC=$O(^LRO(69,BLRVDT,1,"AN",LOC)) Q:LOC=""  D

 ..S LRDFN=""

 ..F  S LRDFN=$O(^LRO(69,BLRVDT,1,"AN",LOC,LRDFN)) Q:'LRDFN  D

 ...S LRIDT=9999999-BLRVDT-.5              ; Create Inverse Date

 ...;

 ...S X=$$FMADD^XLFDT(BLRVDT,-545)         ; Subtracts 545 days from BLRVDT

 ...S LRIDTLM=9999999-X                    ; Sets Minimum "Inverse Date"

 ...F  S LRIDT=$O(^LRO(69,BLRVDT,1,"AN",LOC,LRDFN,LRIDT)) Q:'LRIDT!(LRIDT>LRIDTLM)  D

 ....Q:'$D(^LR(LRDFN,"CH",LRIDT,0))        ; Quit if no CH data

 ....;

 ....; S X=$P(^LR(LRDFN,"CH",LRIDT,0),U,3)\1  ; Date Report Completed

 ....; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 ....S X=$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3)\1  ; Date Report Completed

 ....; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 ....Q:X'=BLRVDT                            ; Quit if no Report Comp Date

 ....;

 ....S D0=0

 ....F  S D0=$O(^BLRSHDRD(D0)) Q:'D0  D

 .....S BLRTPTR=$P($G(^BLRSHDRD(D0,0)),U,1)

 .....S BLRTYPE=""

 .....I $P($G(^LAB(60,BLRTPTR,0)),U,12)'="" D

 ......S TMPIT=U_$P($G(^LAB(60,BLRTPTR,0)),U,12)_"0)"

 ......I $D(@TMPIT)<1 Q

 ......S BLRTYPE=$P(@(U_$P($G(^LAB(60,BLRTPTR,0)),U,12)_"0)"),U,2)

 .....I $G(BLRTYPE)="" Q                    ; Quit if no data type for test

 .....;

 .....S BLRDLOC=$P($G(^LAB(60,BLRTPTR,0)),U,5)

 .....I $G(BLRDLOC)="" Q                    ; Quit f no Location

 .....;

 .....; S ^BLRDEBUG(LRDFN,LRIDT,D0,"BLRTYPE")=BLRTYPE

 .....; S ^BLRDEBUG(LRDFN,LRIDT,D0,"BLRDLOC")=BLRDLOC

 .....;

 .....Q:'$D(^LR(LRDFN,"CH",LRIDT,$P(BLRDLOC,";",2)))  ; Quit if not CH

 .....;

 .....; S BLRRES=$P(^LR(LRDFN,"CH",LRIDT,$P(BLRDLOC,";",2)),U,1)

 .....; S BLRFLD=$P(^LAB(60,BLRTPTR,0),U,12)

 .....; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 ..... S BLRRES=$P($G(^LR(LRDFN,"CH",LRIDT,$P(BLRDLOC,";",2))),U,1)

 ..... S BLRFLD=$P($G(^LAB(60,BLRTPTR,0)),U,12)

 .....; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 .....S BLRRAWRS=BLRRES

 .....;

 .....S TRANS=$G(^BLRSHDRD(D0,2))

 .....I $L(TRANS) D                         ; If Transform code, execute it

 ......S Y=BLRRES

 ......K X

 ......X TRANS

 ......Q:'$D(X)

 ......S BLRRES=X

 .....;

 .....I $E(BLRTYPE,1)="N" D  Q              ; Numeric Data Type

 ......S COND=$P($G(^BLRSHDRD(D0,0)),U,4)

 ......S COND=$S(COND=2:"[",COND=4:"<",COND=5:"=",COND=6:">",1:"")

 ......I $G(COND)="" Q

 ......S VALUE=$P($G(^BLRSHDRD(D0,0)),U,3)

 ......I $E(BLRRES,1)=">" S BLRRES=$P(BLRRES,">",2)+1

 ......S BLRRES=+BLRRES

 ......I @(BLRRES_COND_VALUE) D STORE

 .....;

 .....I $E(BLRTYPE,1)="S" D  Q              ; Set Data Type

 ......;What the values stand for in the set

 ......S BLRSTNFR=$P(@(U_BLRFLD_"0)"),U,3)

 ......F I=1:1 S Y=$P(BLRSTNFR,";",I) Q:Y=""  D

 .......I $P(Y,":",1)=BLRRAWRS D

 ........ I $L($P(Y,":",1))>$L(BLRRAWRS) S BLRRAWRS=$P(Y,":",1) Q

 ........ I $L($P(Y,":",2))>$L(BLRRAWRS) S BLRRAWRS=$P(Y,":",2)

 .......I $P(Y,":",2)=BLRRAWRS D

 ........ I $L($P(Y,":",1))>$L(BLRRAWRS) S BLRRAWRS=$P(Y,":",1) Q

 ........ I $L($P(Y,":",2))>$L(BLRRAWRS) S BLRRAWRS=$P(Y,":",2)

 ......S D1=0

 ......F  S D1=$O(^BLRSHDRD(D0,1,D1)) Q:'D1  D

 .......S VALUE=$P($G(^BLRSHDRD(D0,1,D1,0)),U,1)

 .......I BLRRES=VALUE D STORE

 .....;

 .....I $E(BLRTYPE,1)="F" D                 ; Free Text Data Type

 ......I BLRRES'=+BLRRES S BLRRES=""""_BLRRES_""""

 ......S D1=0

 ......F  S D1=$O(^BLRSHDRD(D0,4,D1)) Q:'D1  D

 .......S COND=$P($G(^BLRSHDRD(D0,4,D1,0)),U,2)

 .......S COND=$S(COND=2:"[",COND=4:"<",COND=5:"=",COND=6:">",1:"")

 .......I $G(COND)="" Q

 .......; S COND=$S(COND="C":"[",1:"=")

 .......S VALUE=$P($G(^BLRSHDRD(D0,4,D1,0)),U,1)

 .......I VALUE'=+VALUE S VALUE=""""_VALUE_""""

 .......I @(BLRRES_COND_VALUE) D STORE

 D PEP^BLRSHDRP    ; Print data collected

 ; D ^XBCLS

 D EN^DDIOL(.HEADERS)

 I +$G(PG)>0 W !!!,"Number of pages printed = ",PG-1,!

 I '$D(IO("Q")) D PRESSRTN^BLRSHDRP    ; Press RETURN

 K ^TMP($J)                       ; Clean up

 D ^XBCLS

STORE ;Store data for printing

 K BLRCOMM,BLRCMIN

 ; S BLRFILE=$P(^LR(LRDFN,0),U,2)

 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 S BLRFILE=$P($G(^LR(LRDFN,0)),U,2)

 ; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 S DFN=$P(^LR(LRDFN,0),U,3)

 ; S PATNAM=$S(BLRFILE=2:$P($G(^DPT(DFN,0)),U,1),BLRFILE=67:"*"_$P(^LRT(67,DFN,0),U,1),1:"UNK")

 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 S PATNAM=$S(BLRFILE=2:$P($G(^DPT(DFN,0)),U,1),BLRFILE=67:"*"_$P($G(^LRT(67,DFN,0)),U,1),1:"UNK")

 ; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 S IENS=DFN_","

 S SEX=$$GET1^DIQ(BLRFILE,IENS,.02)

 S DOB=$$GET1^DIQ(BLRFILE,IENS,.03)

 Q:BLRFILE=67.3

 I BLRFILE=67 D

 . ;S ID=$P(^LRT(67,DFN,0),U,9)

 . ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 . S ID=$P($G(^LRT(67,DFN,0)),U,9)

 . ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 .S (STREET,CITY,STATE,ZIP,PHONE,BLRCOMM,BLRCMIN)=""

 E  I BLRFILE=2 D

 .S ID=$$HRN^AUPNPAT(DFN,DUZ(2))

 . ; S Y=^DPT(DFN,.11)

 . ;----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 . S Y=$G(^DPT(DFN,.11))

 . ;----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 .S STREET=$P(Y,U,1)

 .S CITY=$P(Y,U,4)

 .S ZIP=$P(Y,U,6)

 .S IENS=DFN_","

 .S STATE=$$GET1^DIQ(2,IENS,.115)

 .S PHONE=$$GET1^DIQ(2,IENS,.131)

 .S BLRCOMM=$$COMMRES^AUPNPAT(DFN,"E")

 .S BLRCMIN=$$COMMRES^AUPNPAT(DFN,"I")

 .I 'BLRCMIN D

 ..; S BLRXCOMM=$P(^AUPNPAT(DFN,11),U,18)

 ..; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 .. S BLRXCOMM=$P($G(^AUPNPAT(DFN,11)),U,18)

 ..; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 ..Q:BLRCOMM=""

 ..S BLRCMIN=$O(^AUTTCOM("B",BLRCOMM,""))

 I BLRCMIN,$D(BLRGR),'$D(^BLRGRHR("B",BLRCMIN)) Q

 I $D(BLRGR),'BLRCMIN Q

 S ^TMP($J,D0)=$P($G(^BLRSHDRD(D0,0)),U,2)      ; Reporting Test

 I $G(^TMP($J,D0))="" S ^TMP($J,D0)=$P($G(^LAB(60,BLRTPTR,0)),U,1)

 S ^TMP($J,D0,LRDFN,LRIDT)=PATNAM_U_ID_U_DOB_U_SEX_U_PHONE_U_STREET_U_CITY_U_STATE_U_ZIP_U_BLRCOMM_U_BLRRAWRS

 ; NOTE: The variables HEADER1 & HEADER2 hold the "header" information for the

 ;       report, which must be 132 columns wide.  That is why the Right Margin

 ;       is hard-coded to 132 for those 2 variables.

GETSITE      ;

 D MAKESITE                       ; Get Site parameters

 D MAKEHDRS                       ; Create Header Strings

MAKEHDRS ; EP

 S STR=$$CJ^XLFSTR(SITENAME,132)

 S $E(STR,1,28)=SITESTAB_" HEALTH DEPARTMENT REPORT"

 S HEADER1=STR                    ; HEADER LINE 1

 S HEADER2=$$CJ^XLFSTR(SITEADDR_", "_SITECITY_", "_SITESTAB_" "_SITEZIP,132)

 I $TR($TR(HEADER2,",")," ")="" S HEADER2=""     ; If nothing, set to null

 ; Screen Header

 NEW TMPLN                        ; Temporary Line

 S TMPLN=$$CJ^XLFSTR(SITENAME,IOM)

 S $E(TMPLN,1,13)="Date:"_$$NUMDATE^BLRUTIL($$DT^XLFDT())             ; Today's Date

 S $E(TMPLN,IOM-16)=$J("Time:"_$$NUMTIME^BLRUTIL($$NOW^XLFDT()),16)   ; Current Time

 S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")                 ; Trim extra spaces

 S HEADERS(1)=TMPLN

 S BLRVERN="1.01.02"              ; Version number

 S TMPLN=$$CJ^XLFSTR(SITESTAB_" Health Department Report",IOM)    ; Center Header Line 2

 S $E(TMPLN,IOM-11)=$J(BLRVERN,11)     ; Version Number

 S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")  ; Trim extra spaces

 S HEADERS(2)=TMPLN

 S HEADERS(3)=$TR($J("",IOM-1)," ","-")     ; Dashed line

 S HEADERS(4)=" "                           ; Blank line

MAKESITE ;

 W !!!

 D ^XBFMK

 D GETDUZS

 S DIR("A")="Use Site "_SITENAME_" as Report Header"

 S DIR("B")="YES"

 S DIR(0)="Y"

 D ^DIR

 I X["Y" Q                        ; Accepted Default

 ; Did NOT accept default.  Get Institution

 D ^XBFMK

 S DIC=4

 S DIC(0)="ACEIKNQTZ"

 S DIC("B")=SITENAME

 D ^DIC

 I $D(DIRUT) D  Q                 ; If ^, or RETURN, or timed out, Quit

 . K DIR,DIRUT,DTOUT,DUOUT

 . D SETHDRVS($G(DUZ(2)))         ; Something has to be there

 D SETHDRVS(+Y)

 ; Get Site Name/Address using DUZ(2)

GETDUZS ;

 D SETHDRVS($G(DUZ(2)))           ; Set HeaDeR VariableS

 S DIR("A",1)="Default Site/Address for Report:"

 S DIR("A",2)=" "

 S DIR("A",3)="     "_SITENAME

 S DIR("A",4)="     "_SITEADDR

 S DIR("A",5)="     "_SITECITY_", "_SITESTAB_" "_SITEZIP

 S DIR("A",6)=" "

 ; SET HeaDeR VariableS -- use ONLY values in dictionaries.

 ; NO FREE TEXT.

SETHDRVS(DIC4PTR)      ; EP

 S SITENAME=$$GET1^DIQ(4,DIC4PTR_",","NAME")

 S SITESTAB=$$GET1^DIQ(4,DIC4PTR_",","STATE:ABBREVIATION")

 S SITESTNM=$$GET1^DIQ(4,DIC4PTR_",","STATE:NAME")

 S SITEADDR=$$GET1^DIQ(4,DIC4PTR_",","STREET ADDR. 1")

 S STR=$$GET1^DIQ(4,DIC4PTR_",","STREET ADDR. 2")

 I $G(STR)'="" S SITEADDR=SITEADDR_" "_STR

 S SITECITY=$$GET1^DIQ(4,DIC4PTR_",","CITY")

 S SITEZIP=$$GET1^DIQ(4,DIC4PTR_",","ZIP")

 S ^TMP($J,"DIC4PTR")=DIC4PTR

BLRSHDRC  ; IHS/OIT/MKK - NON MICRO STATE HEALTH DEPT REPORT MAIN [ 07/22/2005 ]

 +1       ;;5.2;LR;**1020,1022**;September 20, 2007

 +2       ;;

 +3       ; Lab PSG gave permission to retrieve programs from PIMC and distribute

 +4       ; nationally.  The original routines at PIMC are BZXLRSER and BZXLRSEP.

 +5       ;

 +6       ; Note that ^BLRSHDRD is the new global name for the new dictionary that

 +7       ; this routine depends upon:  REPORTABLE LAB TESTS (# 90475)

 +8       ; It has been distributed with this patch and number given to it by

 +9       ; the IHS DBA.

 +10      ;

 +11      ; This is the driver and compiler of data.

 +12      ; It calls BLRSHDRP as the routine to do the actual printing

 +13      ;

 +14      ; The following is code to prevent routine from being run by D ^BLRLRSER.

EP        ;

 +1       ; Bell/Beep

           WRITE !,$CHAR(7),$CHAR(7),$CHAR(7),!

 +2       ; Failsafe code

           WRITE "Run from Label ONLY",!!

 +3        QUIT

 +4       ;

PEP       ; EP -- Private

 +1        NEW HEADER1,HEADER2,HEADERS

 +2        NEW STR,SITENAME,SITEADDR,SITECITY,SITESTPT,SITESTAB,SITESTNM,SITEZIP

 +3       ;

 +4       ; If no IOM, then setup Interactive IO vars

           IF $GET(IOM)=""

               DO HOME^%ZIS

 +5       ;

 +6       ; Clean up

           KILL ^TMP($JOB)

 +7       ;

 +8       ; Get site information

           DO GETSITE

 +9       ;

 +10      ; Clear screen and home cursor

           DO ^XBCLS

 +11      ; Write the Screen Header Lines

           DO EN^DDIOL(.HEADERS)

 +12      ;

 +13      ; Clear FileMan variables

           DO ^XBFMK

 +14       SET DIR("A")="Enter start date"

 +15       SET DIR(0)="D^::EPX"

 +16       DO ^DIR

 +17      ; If ^, or RETURN, or timed out, Quit

           IF $DATA(DIRUT)

               Begin DoDot:1

 +18               KILL DIR,DIRUT,DTOUT,DUOUT

               End DoDot:1

               QUIT

 +19      ;

 +20      ; Start Date

           SET BLRSDT=Y

 +21      ; Trick for $Order function -- see LP label

           SET BLRVDT=Y-.5

 +22      ;

GETEND    ;

 +1        SET DIR("A")="Enter end date"

 +2        SET DIR(0)="D^::EPX"

 +3        DO ^DIR

 +4        IF $DATA(DIRUT)

               Begin DoDot:1

 +5                KILL DIR,DIRUT,DTOUT,DUOUT,BLRSDT,BLRVDT

               End DoDot:1

               QUIT

 +6        SET BLRENDT=Y

 +7        IF BLRENDT<BLRVDT

               Begin DoDot:1

 +8                WRITE !,"End date cannot be before start date.  Try again."

               End DoDot:1

               GOTO GETEND

 +9       ;

 +10       DO ^XBCLS

 +11       DO EN^DDIOL(.HEADERS)

 +12      ; Wait Message

           DO WAIT^DICD

 +13      ;

LP        ;Start looping through tests

 +1       ; BLRVDT is both the verification date and the order date

 +2       ; In effect we only look at the verification date

 +3       ; Temp variable -- Discar

           NEW TMPIT

 +4       ;

 +5        FOR

               SET BLRVDT=$ORDER(^LRO(69,BLRVDT))

               IF 'BLRVDT!(BLRVDT>BLRENDT)

                   QUIT

               Begin DoDot:1

 +6                SET LOC=""

 +7                FOR

                       SET LOC=$ORDER(^LRO(69,BLRVDT,1,"AN",LOC))

                       IF LOC=""

                           QUIT

                       Begin DoDot:2

 +8                        SET LRDFN=""

 +9                        FOR

                               SET LRDFN=$ORDER(^LRO(69,BLRVDT,1,"AN",LOC,LRDFN))

                               IF 'LRDFN

                                   QUIT

                               Begin DoDot:3

 +10      ; Create Inverse Date

                                   SET LRIDT=9999999-BLRVDT-.5

 +11      ;

 +12      ; Subtracts 545 days from BLRVDT

                                   SET X=$$FMADD^XLFDT(BLRVDT,-545)

 +13      ; Sets Minimum "Inverse Date"

                                   SET LRIDTLM=9999999-X

 +14                               FOR

                                       SET LRIDT=$ORDER(^LRO(69,BLRVDT,1,"AN",LOC,LRDFN,LRIDT))

                                       IF 'LRIDT!(LRIDT>LRIDTLM)

                                           QUIT

                                       Begin DoDot:4

 +15      ; Quit if no CH data

                                           IF '$DATA(^LR(LRDFN,"CH",LRIDT,0))

                                               QUIT

 +16      ;

 +17      ; S X=$P(^LR(LRDFN,"CH",LRIDT,0),U,3)\1  ; Date Report Completed

 +18      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +19      ; Date Report Completed

                                           SET X=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)\1

 +20      ; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +21      ; Quit if no Report Comp Date

                                           IF X'=BLRVDT

                                               QUIT

 +22      ;

 +23                                       SET D0=0

 +24                                       FOR

                                               SET D0=$ORDER(^BLRSHDRD(D0))

                                               IF 'D0

                                                   QUIT

                                               Begin DoDot:5

 +25                                               SET BLRTPTR=$PIECE($GET(^BLRSHDRD(D0,0)),U,1)

 +26                                               SET BLRTYPE=""

 +27                                               IF $PIECE($GET(^LAB(60,BLRTPTR,0)),U,12)'=""

                                                       Begin DoDot:6

 +28                                                       SET TMPIT=U_$PIECE($GET(^LAB(60,BLRTPTR,0)),U,12)_"0)"

 +29                                                       IF $DATA(@TMPIT)<1

                                                               QUIT

 +30                                                       SET BLRTYPE=$PIECE(@(U_$PIECE($GET(^LAB(60,BLRTPTR,0)),U,12)_"0)"),U,2)

                                                       End DoDot:6

 +31      ; Quit if no data type for test

                                                   IF $GET(BLRTYPE)=""

                                                       QUIT

 +32      ;

 +33                                               SET BLRDLOC=$PIECE($GET(^LAB(60,BLRTPTR,0)),U,5)

 +34      ; Quit f no Location

                                                   IF $GET(BLRDLOC)=""

                                                       QUIT

 +35      ;

 +36      ; S ^BLRDEBUG(LRDFN,LRIDT,D0,"BLRTYPE")=BLRTYPE

 +37      ; S ^BLRDEBUG(LRDFN,LRIDT,D0,"BLRDLOC")=BLRDLOC

 +38      ;

 +39      ; Quit if not CH

                                                   IF '$DATA(^LR(LRDFN,"CH",LRIDT,$PIECE(BLRDLOC,";",2)))

                                                       QUIT

 +40      ;

 +41      ; S BLRRES=$P(^LR(LRDFN,"CH",LRIDT,$P(BLRDLOC,";",2)),U,1)

 +42      ; S BLRFLD=$P(^LAB(60,BLRTPTR,0),U,12)

 +43      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +44                                               SET BLRRES=$PIECE($GET(^LR(LRDFN,"CH",LRIDT,$PIECE(BLRDLOC,";",2))),U,1)

 +45                                               SET BLRFLD=$PIECE($GET(^LAB(60,BLRTPTR,0)),U,12)

 +46      ; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +47                                               SET BLRRAWRS=BLRRES

 +48      ;

 +49                                               SET TRANS=$GET(^BLRSHDRD(D0,2))

 +50      ; If Transform code, execute it

                                                   IF $LENGTH(TRANS)

                                                       Begin DoDot:6

 +51                                                       SET Y=BLRRES

 +52                                                       KILL X

 +53                                                       XECUTE TRANS

 +54                                                       IF '$DATA(X)

                                                               QUIT

 +55                                                       SET BLRRES=X

                                                       End DoDot:6

 +56      ;

 +57      ; Numeric Data Type

                                                   IF $EXTRACT(BLRTYPE,1)="N"

                                                       Begin DoDot:6

 +58                                                       SET COND=$PIECE($GET(^BLRSHDRD(D0,0)),U,4)

 +59                                                       SET COND=$SELECT(COND=2:"[",COND=4:"<",COND=5:"=",COND=6:">",1:"")

 +60                                                       IF $GET(COND)=""

                                                               QUIT

 +61                                                       SET VALUE=$PIECE($GET(^BLRSHDRD(D0,0)),U,3)

 +62                                                       IF $EXTRACT(BLRRES,1)=">"

                                                               SET BLRRES=$PIECE(BLRRES,">",2)+1

 +63                                                       SET BLRRES=+BLRRES

 +64                                                       IF @(BLRRES_COND_VALUE)

                                                               DO STORE

                                                       End DoDot:6

                                                       QUIT

 +65      ;

 +66      ; Set Data Type

                                                   IF $EXTRACT(BLRTYPE,1)="S"

                                                       Begin DoDot:6

 +67      ;What the values stand for in the set

 +68                                                       SET BLRSTNFR=$PIECE(@(U_BLRFLD_"0)"),U,3)

 +69                                                       FOR I=1:1

                                                               SET Y=$PIECE(BLRSTNFR,";",I)

                                                               IF Y=""

                                                                   QUIT

                                                               Begin DoDot:7

 +70                                                               IF $PIECE(Y,":",1)=BLRRAWRS

                                                                       Begin DoDot:8

 +71                                                                       IF $LENGTH($PIECE(Y,":",1))>$LENGTH(BLRRAWRS)

                                                                               SET BLRRAWRS=$PIECE(Y,":",1)

                                                                               QUIT

 +72                                                                       IF $LENGTH($PIECE(Y,":",2))>$LENGTH(BLRRAWRS)

                                                                               SET BLRRAWRS=$PIECE(Y,":",2)

                                                                       End DoDot:8

 +73                                                               IF $PIECE(Y,":",2)=BLRRAWRS

                                                                       Begin DoDot:8

 +74                                                                       IF $LENGTH($PIECE(Y,":",1))>$LENGTH(BLRRAWRS)

                                                                               SET BLRRAWRS=$PIECE(Y,":",1)

                                                                               QUIT

 +75                                                                       IF $LENGTH($PIECE(Y,":",2))>$LENGTH(BLRRAWRS)

                                                                               SET BLRRAWRS=$PIECE(Y,":",2)

                                                                       End DoDot:8

                                                               End DoDot:7

 +76                                                       SET D1=0

 +77                                                       FOR

                                                               SET D1=$ORDER(^BLRSHDRD(D0,1,D1))

                                                               IF 'D1

                                                                   QUIT

                                                               Begin DoDot:7

 +78                                                               SET VALUE=$PIECE($GET(^BLRSHDRD(D0,1,D1,0)),U,1)

 +79                                                               IF BLRRES=VALUE

                                                                       DO STORE

                                                               End DoDot:7

                                                       End DoDot:6

                                                       QUIT

 +80      ;

 +81      ; Free Text Data Type

                                                   IF $EXTRACT(BLRTYPE,1)="F"

                                                       Begin DoDot:6

 +82                                                       IF BLRRES'=+BLRRES

                                                               SET BLRRES=""""_BLRRES_""""

 +83                                                       SET D1=0

 +84                                                       FOR

                                                               SET D1=$ORDER(^BLRSHDRD(D0,4,D1))

                                                               IF 'D1

                                                                   QUIT

                                                               Begin DoDot:7

 +85                                                               SET COND=$PIECE($GET(^BLRSHDRD(D0,4,D1,0)),U,2)

 +86                                                               SET COND=$SELECT(COND=2:"[",COND=4:"<",COND=5:"=",COND=6:">",1:"")

 +87                                                               IF $GET(COND)=""

                                                                       QUIT

 +88      ; S COND=$S(COND="C":"[",1:"=")

 +89                                                               SET VALUE=$PIECE($GET(^BLRSHDRD(D0,4,D1,0)),U,1)

 +90                                                               IF VALUE'=+VALUE

                                                                       SET VALUE=""""_VALUE_""""

 +91                                                               IF @(BLRRES_COND_VALUE)

                                                                       DO STORE

                                                               End DoDot:7

                                                       End DoDot:6

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +92      ;

 +93      ; Print data collected

           DO PEP^BLRSHDRP

 +94      ;

 +95      ; D ^XBCLS

 +96       DO EN^DDIOL(.HEADERS)

 +97       IF +$GET(PG)>0

               WRITE !!!,"Number of pages printed = ",PG-1,!

 +98      ; Press RETURN

           IF '$DATA(IO("Q"))

               DO PRESSRTN^BLRSHDRP

 +99      ;

 +100     ; Clean up

           KILL ^TMP($JOB)

 +101     ;

 +102      DO ^XBCLS

 +103     ;

 +104      QUIT

 +105     ;

STORE     ;Store data for printing

 +1        KILL BLRCOMM,BLRCMIN

 +2       ; S BLRFILE=$P(^LR(LRDFN,0),U,2)

 +3       ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +4        SET BLRFILE=$PIECE($GET(^LR(LRDFN,0)),U,2)

 +5       ; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +6        SET DFN=$PIECE(^LR(LRDFN,0),U,3)

 +7       ; S PATNAM=$S(BLRFILE=2:$P($G(^DPT(DFN,0)),U,1),BLRFILE=67:"*"_$P(^LRT(67,DFN,0),U,1),1:"UNK")

 +8       ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +9        SET PATNAM=$SELECT(BLRFILE=2:$PIECE($GET(^DPT(DFN,0)),U,1),BLRFILE=67:"*"_$PIECE($GET(^LRT(67,DFN,0)),U,1),1:"UNK")

 +10      ; ----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +11       SET IENS=DFN_","

 +12       SET SEX=$$GET1^DIQ(BLRFILE,IENS,.02)

 +13       SET DOB=$$GET1^DIQ(BLRFILE,IENS,.03)

 +14       IF BLRFILE=67.3

               QUIT

 +15       IF BLRFILE=67

               Begin DoDot:1

 +16      ;S ID=$P(^LRT(67,DFN,0),U,9)

 +17      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +18               SET ID=$PIECE($GET(^LRT(67,DFN,0)),U,9)

 +19      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +20               SET (STREET,CITY,STATE,ZIP,PHONE,BLRCOMM,BLRCMIN)=""

               End DoDot:1

 +21      IF '$TEST

               IF BLRFILE=2

                   Begin DoDot:1

 +22                   SET ID=$$HRN^AUPNPAT(DFN,DUZ(2))

 +23      ; S Y=^DPT(DFN,.11)

 +24      ;----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +25                   SET Y=$GET(^DPT(DFN,.11))

 +26      ;----- END IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +27                   SET STREET=$PIECE(Y,U,1)

 +28                   SET CITY=$PIECE(Y,U,4)

 +29                   SET ZIP=$PIECE(Y,U,6)

 +30                   SET IENS=DFN_","

 +31                   SET STATE=$$GET1^DIQ(2,IENS,.115)

 +32                   SET PHONE=$$GET1^DIQ(2,IENS,.131)

 +33                   SET BLRCOMM=$$COMMRES^AUPNPAT(DFN,"E")

 +34                   SET BLRCMIN=$$COMMRES^AUPNPAT(DFN,"I")

 +35                   IF 'BLRCMIN

                           Begin DoDot:2

 +36      ; S BLRXCOMM=$P(^AUPNPAT(DFN,11),U,18)

 +37      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +38                           SET BLRXCOMM=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)

 +39      ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1022 - Naked reference correction

 +40                           IF BLRCOMM=""

                                   QUIT

 +41                           SET BLRCMIN=$ORDER(^AUTTCOM("B",BLRCOMM,""))

                           End DoDot:2

                   End DoDot:1

 +42       IF BLRCMIN

               IF $DATA(BLRGR)

                   IF '$DATA(^BLRGRHR("B",BLRCMIN))

                       QUIT

 +43       IF $DATA(BLRGR)

               IF 'BLRCMIN

                   QUIT

 +44      ; Reporting Test

           SET ^TMP($JOB,D0)=$PIECE($GET(^BLRSHDRD(D0,0)),U,2)

 +45       IF $GET(^TMP($JOB,D0))=""

               SET ^TMP($JOB,D0)=$PIECE($GET(^LAB(60,BLRTPTR,0)),U,1)

 +46       SET ^TMP($JOB,D0,LRDFN,LRIDT)=PATNAM_U_ID_U_DOB_U_SEX_U_PHONE_U_STREET_U_CITY_U_STATE_U_ZIP_U_BLRCOMM_U_BLRRAWRS

 +47       QUIT

 +48      ;

 +49      ; NOTE: The variables HEADER1 & HEADER2 hold the "header" information for the

 +50      ;       report, which must be 132 columns wide.  That is why the Right Margin

 +51      ;       is hard-coded to 132 for those 2 variables.

GETSITE   ;

 +1       ;

 +2       ; Get Site parameters

           DO MAKESITE

 +3       ;

 +4       ; Create Header Strings

           DO MAKEHDRS

 +5       ;

 +6        QUIT

MAKEHDRS  ; EP

 +1       ;

 +2        SET STR=$$CJ^XLFSTR(SITENAME,132)

 +3        SET $EXTRACT(STR,1,28)=SITESTAB_" HEALTH DEPARTMENT REPORT"

 +4       ; HEADER LINE 1

           SET HEADER1=STR

 +5       ;

 +6        SET HEADER2=$$CJ^XLFSTR(SITEADDR_", "_SITECITY_", "_SITESTAB_" "_SITEZIP,132)

 +7       ; If nothing, set to null

           IF $TRANSLATE($TRANSLATE(HEADER2,",")," ")=""

               SET HEADER2=""

 +8       ;

 +9       ; Screen Header

 +10      ; Temporary Line

           NEW TMPLN

 +11      ;

 +12       SET TMPLN=$$CJ^XLFSTR(SITENAME,IOM)

 +13      ; Today's Date

           SET $EXTRACT(TMPLN,1,13)="Date:"_$$NUMDATE^BLRUTIL($$DT^XLFDT())

 +14      ; Current Time

           SET $EXTRACT(TMPLN,IOM-16)=$JUSTIFY("Time:"_$$NUMTIME^BLRUTIL($$NOW^XLFDT()),16)

 +15      ; Trim extra spaces

           SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +16       SET HEADERS(1)=TMPLN

 +17      ;

 +18      ; Version number

           SET BLRVERN="1.01.02"

 +19      ; Center Header Line 2

           SET TMPLN=$$CJ^XLFSTR(SITESTAB_" Health Department Report",IOM)

 +20      ; Version Number

           SET $EXTRACT(TMPLN,IOM-11)=$JUSTIFY(BLRVERN,11)

 +21      ; Trim extra spaces

           SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")

 +22       SET HEADERS(2)=TMPLN

 +23      ;

 +24      ; Dashed line

           SET HEADERS(3)=$TRANSLATE($JUSTIFY("",IOM-1)," ","-")

 +25      ; Blank line

           SET HEADERS(4)=" "

 +26      ;

 +27       QUIT

 +28      ;

MAKESITE  ;

 +1        WRITE !!!

 +2        DO ^XBFMK

 +3        DO GETDUZS

 +4       ;

 +5        SET DIR("A")="Use Site "_SITENAME_" as Report Header"

 +6        SET DIR("B")="YES"

 +7        SET DIR(0)="Y"

 +8        DO ^DIR

 +9       ; Accepted Default

           IF X["Y"

               QUIT

 +10      ;

 +11      ; Did NOT accept default.  Get Institution

 +12       DO ^XBFMK

 +13       SET DIC=4

 +14       SET DIC(0)="ACEIKNQTZ"

 +15       SET DIC("B")=SITENAME

 +16       DO ^DIC

 +17      ; If ^, or RETURN, or timed out, Quit

           IF $DATA(DIRUT)

               Begin DoDot:1

 +18               KILL DIR,DIRUT,DTOUT,DUOUT

 +19      ; Something has to be there

                   DO SETHDRVS($GET(DUZ(2)))

               End DoDot:1

               QUIT

 +20      ;

 +21       DO SETHDRVS(+Y)

 +22      ;

 +23       QUIT

 +24      ;

 +25      ; Get Site Name/Address using DUZ(2)

GETDUZS   ;

 +1       ; Set HeaDeR VariableS

           DO SETHDRVS($GET(DUZ(2)))

 +2       ;

 +3        SET DIR("A",1)="Default Site/Address for Report:"

 +4        SET DIR("A",2)=" "

 +5        SET DIR("A",3)="     "_SITENAME

 +6        SET DIR("A",4)="     "_SITEADDR

 +7        SET DIR("A",5)="     "_SITECITY_", "_SITESTAB_" "_SITEZIP

 +8        SET DIR("A",6)=" "

 +9       ;

 +10       QUIT

 +11      ;

 +12      ; SET HeaDeR VariableS -- use ONLY values in dictionaries.

 +13      ; NO FREE TEXT.

SETHDRVS(DIC4PTR) ; EP

 +1        SET SITENAME=$$GET1^DIQ(4,DIC4PTR_",","NAME")

 +2       ;

 +3        SET SITESTAB=$$GET1^DIQ(4,DIC4PTR_",","STATE:ABBREVIATION")

 +4        SET SITESTNM=$$GET1^DIQ(4,DIC4PTR_",","STATE:NAME")

 +5       ;

 +6        SET SITEADDR=$$GET1^DIQ(4,DIC4PTR_",","STREET ADDR. 1")

 +7        SET STR=$$GET1^DIQ(4,DIC4PTR_",","STREET ADDR. 2")

 +8        IF $GET(STR)'=""

               SET SITEADDR=SITEADDR_" "_STR

 +9       ;

 +10       SET SITECITY=$$GET1^DIQ(4,DIC4PTR_",","CITY")

 +11       SET SITEZIP=$$GET1^DIQ(4,DIC4PTR_",","ZIP")

 +12      ;

 +13       SET ^TMP($JOB,"DIC4PTR")=DIC4PTR

 +14       QUIT

BLRSHDRC.m