BDGIPL8.m

BDGIPL8 ; IHS/ANMC/LJF - CURR INPTS BY LOS ; 

 ;;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 BY LOS

 ; assumes BDGSRT and BDGSRT2 are set

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG IPL BY LOS")

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

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

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

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

 S X="With LOS of "_BDGSRT2_" Days or Greater"

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

 Q

 ;

INIT ; -- init variables and list array

 NEW WD,DFN,BDGCNT,NAME

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

 S VALMCNT=0,BDGCNT=1

 ;

 ; if only one ward chosen

 I BDGSRT D

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

 .. ;

 .. ; check patient length of stay against user's request

 .. S D0=+$G(^DPT(DFN,.105)),X="" Q:'$D(^DGPM(D0,0))

 .. D EN^DGPMLOS I +X<BDGSRT2 Q

 .. ;

 .. S ^TMP("BDGIPL1",$J,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""

 ;

 ; OR for all wards, find current inpatients & sort by ward then name

 E  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

 .. ;

 .. ; check patient length of stay against user's request

 .. S D0=+$G(^DPT(DFN,.105)),X="" Q:'$D(^DGPM(D0,0))

 .. D EN^DGPMLOS I +X<BDGSRT2 Q

 .. ;

 .. S ^TMP("BDGIPL1",$J,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""

 ;

 ; pull sorted list and create display array

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

 . ;

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

 .. D SET($G(IORVON)_"WARD: "_WD_$G(IORVOFF),.VALMCNT,BDGCNT,"")

 . ;

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

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

 ... D LINE

 . ;

 . D SET("",.VALMCNT,BDGCNT-1,"")

 ;

 K ^TMP("BDGIPL1",$J)

 Q

 ;

LINE ; set up dislay line for patient

 NEW LINE

 S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")

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

 S LINE=$$PAD(LINE,25)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)           ;hrcn

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

 S LINE=$$PAD(LINE,41)_$P($$GET1^DIQ(2,DFN,.105),",")           ;admit

 S LINE=$$PAD(LINE,50)_$J($P($$CURLOS^BDGF1(DFN)," "),3)        ;los

 S LINE=$$PAD(LINE,57)_$$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99)  ;srv

 S LINE=$$PAD(LINE,63)_$$GET1^DIQ(9000001,DFN,1118)             ;comm

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

 ;

 ; increment counter

 S BDGCNT=BDGCNT+1

 Q

 ;

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

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

 Q

 ;

PRINT ; print report to paper

 NEW BDGX,BDGLN,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

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

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

 . 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

 S X="Inpatients With LOS of "_BDGSRT2_" Days or Greater"

 W !,BDGDATE,?(80-$L(X)\2),X,?70,"Page: ",BDGPG

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

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

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

 W !?5,"Patient",?25,"Chart #",?35,"Age",?41,"Admit",?50,"LOS"

 W ?57,"Srv",?63,"Community"

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

 Q

 ;

HELP ; -- help code

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

 Q

 ;

EXIT ; -- exit code

 K ^TMP("BDGIPL",$J)

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

 Q

 ;

EXPND ; -- expand code

 Q

 ;

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

BDGIPL8   ; IHS/ANMC/LJF - CURR INPTS BY LOS ; 

 +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 BY LOS

 +1       ; assumes BDGSRT and BDGSRT2 are set

 +2        NEW VALMCNT

           DO TERM^VALM0

           DO CLEAR^VALM1

 +3        DO EN^VALM("BDG IPL BY LOS")

 +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 Ward Locations",1:$PIECE(BDGSRT,U,2))

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

 +5        SET X="With LOS of "_BDGSRT2_" Days or Greater"

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

 +7        QUIT 

 +8       ;

INIT      ; -- init variables and list array

 +1        NEW WD,DFN,BDGCNT,NAME

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

 +3        SET VALMCNT=0

           SET BDGCNT=1

 +4       ;

 +5       ; if only one ward chosen

 +6        IF BDGSRT

               Begin DoDot:1

 +7                SET WD=$PIECE(BDGSRT,U,2)

                   SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +8       ;

 +9       ; check patient length of stay against user's request

 +10                       SET D0=+$GET(^DPT(DFN,.105))

                           SET X=""

                           IF '$DATA(^DGPM(D0,0))

                               QUIT 

 +11                       DO EN^DGPMLOS

                           IF +X<BDGSRT2

                               QUIT 

 +12      ;

 +13                       SET ^TMP("BDGIPL1",$JOB,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""

                       End DoDot:2

               End DoDot:1

 +14      ;

 +15      ; OR for all wards, find current inpatients & sort by ward then name

 +16      IF '$TEST

               SET WD=0

               FOR 

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

                   IF WD=""

                       QUIT 

                   Begin DoDot:1

 +17                   SET DFN=0

                       FOR 

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

                           IF 'DFN

                               QUIT 

                           Begin DoDot:2

 +18      ;

 +19      ; check patient length of stay against user's request

 +20                           SET D0=+$GET(^DPT(DFN,.105))

                               SET X=""

                               IF '$DATA(^DGPM(D0,0))

                                   QUIT 

 +21                           DO EN^DGPMLOS

                               IF +X<BDGSRT2

                                   QUIT 

 +22      ;

 +23                           SET ^TMP("BDGIPL1",$JOB,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""

                           End DoDot:2

                   End DoDot:1

 +24      ;

 +25      ; pull sorted list and create display array

 +26       SET WD=0

           FOR 

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

               IF WD=""

                   QUIT 

               Begin DoDot:1

 +27      ;

 +28      ;display ward subheading

                   IF BDGSRT="A"

                       Begin DoDot:2

 +29                       DO SET($GET(IORVON)_"WARD: "_WD_$GET(IORVOFF),.VALMCNT,BDGCNT,"")

                       End DoDot:2

 +30      ;

 +31               SET NAME=0

                   FOR 

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

                       IF NAME=""

                           QUIT 

                       Begin DoDot:2

 +32                       SET DFN=0

                           FOR 

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

                               IF 'DFN

                                   QUIT 

                               Begin DoDot:3

 +33                               DO LINE

                               End DoDot:3

                       End DoDot:2

 +34      ;

 +35               DO SET("",.VALMCNT,BDGCNT-1,"")

               End DoDot:1

 +36      ;

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

 +38       QUIT 

 +39      ;

LINE      ; set up dislay line for patient

 +1        NEW LINE

 +2        SET LINE=$SELECT($EXTRACT(IOST,1,2)="P-":$$SP(5),1:$JUSTIFY(BDGCNT,3)_") ")

 +3       ;name

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

 +4       ;hrcn

           SET LINE=$$PAD(LINE,25)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)

 +5       ;age

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

 +6       ;admit

           SET LINE=$$PAD(LINE,41)_$PIECE($$GET1^DIQ(2,DFN,.105),",")

 +7       ;los

           SET LINE=$$PAD(LINE,50)_$JUSTIFY($PIECE($$CURLOS^BDGF1(DFN)," "),3)

 +8       ;srv

           SET LINE=$$PAD(LINE,57)_$$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)

 +9       ;comm

           SET LINE=$$PAD(LINE,63)_$$GET1^DIQ(9000001,DFN,1118)

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

 +11      ;

 +12      ; increment counter

 +13       SET BDGCNT=BDGCNT+1

 +14       QUIT 

 +15      ;

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,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                IF $Y>(IOSL-4)

                       DO HDG

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

 +8                WRITE !,BDGLN

               End DoDot:1

 +9       ;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

 +10       DO PRTKL^BDGF

           DO EXIT

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

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

           QUIT 

 +13      ;

HDG       ; heading for paper report

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

           IF BDGPG>1

               WRITE @IOF

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

 +3        SET X="Inpatients With LOS of "_BDGSRT2_" Days or Greater"

 +4        WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?70,"Page: ",BDGPG

 +5        SET X=$SELECT(BDGSRT="A":"For ALL Ward Locations",1:$PIECE(BDGSRT,U,2))

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

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

 +8        WRITE !?5,"Patient",?25,"Chart #",?35,"Age",?41,"Admit",?50,"LOS"

 +9        WRITE ?57,"Srv",?63,"Community"

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

 +11       QUIT 

 +12      ;

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