Routine: BDGIPL6

BDGIPL6 ; IHS/ANMC/LJF - CHAPLAIN'S LIST ;

 ;;5.3;PIMS;**1007**;FEB 27, 2007

 ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39

 I $E(IOST,1,2)="P-" D INIT,PRINT Q

EN ; -- main entry point for BDG IPL CHAPLAIN

 ; assumes BDGSRT is set

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG IPL CHAPLAIN")

 D CLEAR^VALM1

HDR ; -- header code

 NEW X

 S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"

 S X=$S(BDGSRT="A":"For ALL Religions",1:$P(BDGSRT,U,2))

 S VALMHDR(2)=$$SP(75-$L(X)\2)_X

INIT ; -- init variables and list array

 NEW WD,DFN,BDGCNT,NAME,FIRST

 K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)

 S VALMCNT=0,BDGCNT=1,FIRST=1

 ; find current inpatients & sort by religion, ward then room

 S WD=0 F  S WD=$O(^DPT("CN",WD)) Q:WD=""  D

 . S DFN=0 F  S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN  D

 .. S REL=$$GET1^DIQ(2,DFN,.08) Q:REL=""   ;if no rel, don't display

 .. I BDGSRT,REL'=$P(BDGSRT,U,2) Q         ;not selected

 .. S RM=$G(^DPT(DFN,.101)) I RM="" S RM="UNK"

 .. S ^TMP("BDGIPL1",$J,REL,WD,RM,DFN)=""

 ; pull sorted list and create display array

 S REL=0 F  S REL=$O(^TMP("BDGIPL1",$J,REL)) Q:REL=""  D

. ;

 . I BDGSRT="A" D  ;display religion subheading

 .. ; if printer, mark stop to add form feed

 .. I FIRST=0,$E(IOST,1,2)="P-" D SET("@@@@",.VALMCNT,BDGCNT,"")

 .. S FIRST=0

 .. ;

 .. D SET($G(IORVON)_REL_$G(IORVOFF),.VALMCNT,BDGCNT,"")

 .. ;

. ;

 . S WD=0 F  S WD=$O(^TMP("BDGIPL1",$J,REL,WD)) Q:WD=""  D

 .. S RM=0 F  S RM=$O(^TMP("BDGIPL1",$J,REL,WD,RM)) Q:RM=""  D

 ... S DFN=0 F  S DFN=$O(^TMP("BDGIPL1",$J,REL,WD,RM,DFN)) Q:'DFN  D

 .... D LINE

 K ^TMP("BDGIPL1",$J)

LINE ; set up dislay line for patient

 NEW LINE,X

 S X=$O(^DIC(42,"B",WD,0)) I X S X=$$GET1^DIQ(9009016.5,X,.02)

 S LINE=$$PAD(X,7)_RM                                 ;ward abbrv & room

 S LINE=$$PAD(LINE,15)_$E($$GET1^DIQ(2,DFN,.01),1,18)      ;name

 S LINE=$$PAD(LINE,35)_$$AGE(DFN)                          ;age

 S LINE=$$PAD(LINE,45)_$E($$GET1^DIQ(9000001,DFN,1118),1,18)  ;community

 S LINE=$$PAD(LINE,65)_$P($$INPT1^BDGF1(DFN,DT),"@")       ;admit date

 D SET(LINE,.VALMCNT,BDGCNT,DFN)

SET(LINE,NUM,COUNT,IEN) ; put display line into array

 D SET^BDGIPL1(LINE,.NUM,COUNT,IEN)

PRINT ; print report to paper

 NEW BDGX,BDGLN,REL,BDGPG

 U IO D INIT^BDGF,HDG

 ; loop thru display array

 S BDGX=0 F  S BDGX=$O(^TMP("BDGIPL",$J,BDGX)) Q:'BDGX  D

 . S BDGLN=^TMP("BDGIPL",$J,BDGX,0)

. ;

 . ;marker for form feed between religions

 . I $E(BDGLN,1,4)="@@@@" D HDG Q

. ;

 . I $Y>(IOSL-4) D HDG

 . W !,BDGLN

 I '$G(BDGCOP) D ^%ZISC  ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39

 D PRTKL^BDGF,EXIT

 ;D ^%ZISC,PRTKL^BDGF,EXIT  cmi/anch/maw 2/22/2007 orig line

 Q  ;cmi/anch/maw 7/25/2007 quit missing patch 1007

HDG ; heading for paper report

 S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF

 W !,BDGUSR,?16,$$CONF^BDGF

 W !,BDGDATE,?32,"Chaplain's List",?70,"Page: ",BDGPG

 S X=$S(BDGSRT="A":"For ALL Religions",1:$P(BDGSRT,U,2))

 W !,BDGTIME,?(80-$L(X)\2),X

 W !,$$REPEAT^XLFSTR("-",80)

 W !,"Ward",?7,"Room",?15,"Patient Name",?35,"Age",?45,"Community"

 W ?65,"Admit Date"

 W !,$$REPEAT^XLFSTR("=",80)

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

EXIT ; -- exit code

 K ^TMP("BDGIPL",$J)

 ;K BDGSRT  cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007

EXPND ; -- expand code

PAD(D,L) ;EP -- SUBRTN to pad length of data

 ; -- D=data L=length

 Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)

SP(N) ; -- SUBRTN to pad N number of spaces

 Q $$PAD(" ",N)

AGE(P) ; return formatted age

 NEW X S X=$$GET1^DIQ(9000001,DFN,1102.98)

 S X=$J($P(X," "),3)_" "_$E($P(X," ",2),1,2)

Q X

BDGIPL6   ; IHS/ANMC/LJF - CHAPLAIN'S LIST ;

 +1       ;;5.3;PIMS;**1007**;FEB 27, 2007

 +2       ;

 +3       ;

 +4       ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39

 +5       ;

 +6       ;

 +7        IF $EXTRACT(IOST,1,2)="P-"

               DO INIT

               DO PRINT

               QUIT

 +8       ;

EN        ; -- main entry point for BDG IPL CHAPLAIN

 +1       ; assumes BDGSRT is set

 +2        NEW VALMCNT

           DO TERM^VALM0

           DO CLEAR^VALM1

 +3        DO EN^VALM("BDG IPL CHAPLAIN")

 +4        DO CLEAR^VALM1

 +5        QUIT

 +6       ;

HDR       ; -- header code

 +1        NEW X

 +2        SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"

 +3        SET X=$SELECT(BDGSRT="A":"For ALL Religions",1:$PIECE(BDGSRT,U,2))

 +4        SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X

 +5        QUIT

 +6       ;

INIT      ; -- init variables and list array

 +1        NEW WD,DFN,BDGCNT,NAME,FIRST

 +2        KILL ^TMP("BDGIPL",$JOB),^TMP("BDGIPL1",$JOB)

 +3        SET VALMCNT=0

           SET BDGCNT=1

           SET FIRST=1

 +4       ;

 +5       ; find current inpatients & sort by religion, ward then room

 +6        SET WD=0

FOR

               SET WD=$ORDER(^DPT("CN",WD))

               IF WD=""

                   QUIT

               Begin DoDot:1

 +7                SET DFN=0

FOR

                       SET DFN=$ORDER(^DPT("CN",WD,DFN))

                       IF 'DFN

                           QUIT

                       Begin DoDot:2

 +8       ;if no rel, don't display

                           SET REL=$$GET1^DIQ(2,DFN,.08)

                           IF REL=""

                               QUIT

 +9       ;not selected

                           IF BDGSRT

                               IF REL'=$PIECE(BDGSRT,U,2)

                                   QUIT

 +10                       SET RM=$GET(^DPT(DFN,.101))

                           IF RM=""

                               SET RM="UNK"

 +11                       SET ^TMP("BDGIPL1",$JOB,REL,WD,RM,DFN)=""

                       End DoDot:2

               End DoDot:1

 +12      ;

 +13      ; pull sorted list and create display array

 +14       SET REL=0

FOR

               SET REL=$ORDER(^TMP("BDGIPL1",$JOB,REL))

               IF REL=""

                   QUIT

               Begin DoDot:1

 +15      ;

 +16      ;display religion subheading

                   IF BDGSRT="A"

                       Begin DoDot:2

 +17      ; if printer, mark stop to add form feed

 +18                       IF FIRST=0

                               IF $EXTRACT(IOST,1,2)="P-"

                                   DO SET("@@@@",.VALMCNT,BDGCNT,"")

 +19                       SET FIRST=0

 +20      ;

 +21                       DO SET($GET(IORVON)_REL_$GET(IORVOFF),.VALMCNT,BDGCNT,"")

 +22      ;

                       End DoDot:2

 +23      ;

 +24               SET WD=0

FOR

                       SET WD=$ORDER(^TMP("BDGIPL1",$JOB,REL,WD))

                       IF WD=""

                           QUIT

                       Begin DoDot:2

 +25                       SET RM=0

FOR

                               SET RM=$ORDER(^TMP("BDGIPL1",$JOB,REL,WD,RM))

                               IF RM=""

                                   QUIT

                               Begin DoDot:3

 +26                               SET DFN=0

FOR

                                       SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,REL,WD,RM,DFN))

                                       IF 'DFN

                                           QUIT

                                       Begin DoDot:4

 +27                                       DO LINE

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +28      ;

 +29       KILL ^TMP("BDGIPL1",$JOB)

 +30       QUIT

 +31      ;

LINE      ; set up dislay line for patient

 +1        NEW LINE,X

 +2        SET X=$ORDER(^DIC(42,"B",WD,0))

           IF X

               SET X=$$GET1^DIQ(9009016.5,X,.02)

 +3       ;ward abbrv & room

           SET LINE=$$PAD(X,7)_RM

 +4       ;name

           SET LINE=$$PAD(LINE,15)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,18)

 +5       ;age

           SET LINE=$$PAD(LINE,35)_$$AGE(DFN)

 +6       ;community

           SET LINE=$$PAD(LINE,45)_$EXTRACT($$GET1^DIQ(9000001,DFN,1118),1,18)

 +7       ;admit date

           SET LINE=$$PAD(LINE,65)_$PIECE($$INPT1^BDGF1(DFN,DT),"@")

 +8        DO SET(LINE,.VALMCNT,BDGCNT,DFN)

 +9       ;

 +10       QUIT

 +11      ;

SET(LINE,NUM,COUNT,IEN) ; put display line into array

 +1        DO SET^BDGIPL1(LINE,.NUM,COUNT,IEN)

 +2        QUIT

 +3       ;

PRINT     ; print report to paper

 +1        NEW BDGX,BDGLN,REL,BDGPG

 +2        USE IO

           DO INIT^BDGF

           DO HDG

 +3       ;

 +4       ; loop thru display array

 +5        SET BDGX=0

FOR

               SET BDGX=$ORDER(^TMP("BDGIPL",$JOB,BDGX))

               IF 'BDGX

                   QUIT

               Begin DoDot:1

 +6                SET BDGLN=^TMP("BDGIPL",$JOB,BDGX,0)

 +7       ;

 +8       ;marker for form feed between religions

 +9                IF $EXTRACT(BDGLN,1,4)="@@@@"

                       DO HDG

                       QUIT

 +10      ;

 +11               IF $Y>(IOSL-4)

                       DO HDG

 +12               WRITE !,BDGLN

               End DoDot:1

 +13      ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39

           IF '$GET(BDGCOP)

               DO ^%ZISC

 +14       DO PRTKL^BDGF

           DO EXIT

 +15      ;D ^%ZISC,PRTKL^BDGF,EXIT  cmi/anch/maw 2/22/2007 orig line

 +16      ;cmi/anch/maw 7/25/2007 quit missing patch 1007

           QUIT

 +17      ;

HDG       ; heading for paper report

 +1        SET BDGPG=$GET(BDGPG)+1

           IF BDGPG>1

               WRITE @IOF

 +2        WRITE !,BDGUSR,?16,$$CONF^BDGF

 +3        WRITE !,BDGDATE,?32,"Chaplain's List",?70,"Page: ",BDGPG

 +4        SET X=$SELECT(BDGSRT="A":"For ALL Religions",1:$PIECE(BDGSRT,U,2))

 +5        WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X

 +6        WRITE !,$$REPEAT^XLFSTR("-",80)

 +7        WRITE !,"Ward",?7,"Room",?15,"Patient Name",?35,"Age",?45,"Community"

 +8        WRITE ?65,"Admit Date"

 +9        WRITE !,$$REPEAT^XLFSTR("=",80)

 +10       QUIT

 +11      ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("BDGIPL",$JOB)

 +2       ;K BDGSRT  cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007

 +3        QUIT

 +4       ;

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

PAD(D,L)  ;EP -- SUBRTN to pad length of data

 +1       ; -- D=data L=length

 +2        QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)

 +3       ;

SP(N)     ; -- SUBRTN to pad N number of spaces

 +1        QUIT $$PAD(" ",N)

 +2       ;

AGE(P)    ; return formatted age

 +1        NEW X

           SET X=$$GET1^DIQ(9000001,DFN,1102.98)

 +2        SET X=$JUSTIFY($PIECE(X," "),3)_" "_$EXTRACT($PIECE(X," ",2),1,2)

 +3        QUIT X

BDGIPL6.m