BDGCCEN.m

BDGCCEN ; IHS/ANMC/LJF - CURRENT INPT CENSUS ;  [ 05/28/2002  10:15 AM ]

 ;;5.3;PIMS;**1003**;mAY 28, 2004

 ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time to header on paper

 ;

 NEW X S X=$$BROWSE^BDGF I X="B" D EN Q

 I X=U Q

 ;4/26/02 WAR - Commented out next line per LJF1

 ;D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS Q

 ;IHS/ANMC/LJF 5/22/2002 (Next line per Linda's LJF2 5/22/02)

 ;D ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS")

 D ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS","")

 Q

 ;

 ;

EN ;EP; -- main entry point for BDG CURRENT CENSUS

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

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG CURRENT CENSUS")

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

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

 Q

 ;

INIT ; -- init variables and list array

 NEW WD,CNT,PT,S,TOTAL,SRV,ARRAY,NUM,X,TOTAL1,LINE,FIRST,TOTAL2

 K ^TMP("BDGCCEN",$J)

 S VALMCNT=0

 ;

 ; loop thru current inpatients by ward and count

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

 . S NUM=$G(NUM)+1

 . S (CNT,PT)=0 F  S PT=$O(^DPT("CN",WD,PT)) Q:'PT  S CNT=CNT+1

 . S ARRAY(NUM)=WD_U_CNT,TOTAL=$G(TOTAL)+CNT

 ;

 ; loop thru current inpatients by service and count

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

 . S (CNT,PT)=0 F  S PT=$O(^DPT("ATR",S,PT)) Q:'PT  S CNT=CNT+1

 . S X=$$GET1^DIQ(45.7,S,.01) I X["OBSERVATION" S X="ZZ"_X

 . S SRV(X)=CNT,TOTAL1=$G(TOTAL1)+CNT

 ;

 S (S,NUM)=0 F  S S=$O(SRV(S)) Q:S=""  D

 . S X=S I X["ZZ" S X=$P(X,"ZZ",2)   ;put observation srvs last

 . S NUM=NUM+1,$P(ARRAY(NUM),U,3)=X_U_SRV(S)

 ;

 ; take array with counts and set into display array

 S X=0,FIRST=1 F  S X=$O(ARRAY(X)) Q:'X  D

 . ;

 . ; separate observation services from others by a dashed line

 . I $P(ARRAY(X),U,3)["OBSERVATION" D

 .. S TOTAL2=$G(TOTAL2)+$P(ARRAY(X),U,4)  ;total observations

 .. I FIRST D SET($$SP(35)_$$REPEAT^XLFSTR("-",33),.VALMCNT) S FIRST=0

 . ;

 . S LINE=$$PAD($$SP(2)_$P(ARRAY(X),U),20)_$J($P(ARRAY(X),U,2),5)

 . S LINE=$$PAD(LINE,34)_$P(ARRAY(X),U,3)

 . S LINE=$$PAD(LINE,60)_$J($P(ARRAY(X),U,4),5)

 . D SET(LINE,.VALMCNT)

 ;

 ; add totals to display array

 S LINE=$$SP(20)_$$REPEAT^XLFSTR("_",8)

 S LINE=$$PAD(LINE,60)_$$REPEAT^XLFSTR("_",8)

 D SET(LINE,.VALMCNT)

 ;

 S LINE=$$PAD($$SP(20)_$J(+$G(TOTAL),5),60)_$J(+$G(TOTAL1),5)

 D SET(LINE,.VALMCNT)

 ;

 I $G(TOTAL2) D    ;if have observation pt count

 . S LINE=$$PAD($$SP(40)_"(Observation Pts =",60)_$J(TOTAL2,5)_"  )"

 . D SET(LINE,.VALMCNT)

 ;

 Q

 ;

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

 S NUM=NUM+1

 S ^TMP("BDGCCEN",$J,NUM,0)=LINE

 Q

 ;

PRINT ; print report to paper

 NEW BDGX,BDGLN,WARD

 ;U IO

 U IO D HDG  ;IHS/ANMC/LJF 5/22/2002 (per Linda's LJF2 5/22/02)

 ;

 ; loop thru display array

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

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

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

 . W !,BDGLN

 D ^%ZISC,EXIT

 Q

 ;

HDG ; heading for paper report

 ;

 ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time; centered better

 ;D HDR W @IOF,?24,"Current Inpatient Census"

 NEW X W @IOF S X="Current Inpatient Census for "_$$FMTE^XLFDT($$NOW^XLFDT) W ?(80-$L(X)\2),X

 ;F I=1:1 Q:'$D(VALMHDR(I))  W !,VALMHDR(I)

 S X="** "_$$CONF^BDGF_" **" W !,?(80-$L(X)\2),X

 ;

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

 W !?2,"Ward",?20,"# of Pts",?34,"Service",?60,"# of Pts"

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

 Q

 ;

HELP ; -- help code

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

 Q

 ;

EXIT ; -- exit code

 K ^TMP("BDGCCEN",$J)

 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)

BDGCCEN   ; IHS/ANMC/LJF - CURRENT INPT CENSUS ;  [ 05/28/2002  10:15 AM ]

 +1       ;;5.3;PIMS;**1003**;mAY 28, 2004

 +2       ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time to header on paper

 +3       ;

 +4        NEW X

           SET X=$$BROWSE^BDGF

           IF X="B"

               DO EN

               QUIT 

 +5        IF X=U

               QUIT 

 +6       ;4/26/02 WAR - Commented out next line per LJF1

 +7       ;D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS Q

 +8       ;IHS/ANMC/LJF 5/22/2002 (Next line per Linda's LJF2 5/22/02)

 +9       ;D ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS")

 +10       DO ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS","")

 +11       QUIT 

 +12      ;

 +13      ;

EN        ;EP; -- main entry point for BDG CURRENT CENSUS

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

               DO INIT

               DO PRINT

               QUIT 

 +2        NEW VALMCNT

           DO TERM^VALM0

           DO CLEAR^VALM1

 +3        DO EN^VALM("BDG CURRENT CENSUS")

 +4        DO CLEAR^VALM1

 +5        QUIT 

 +6       ;

HDR       ; -- header code

 +1        NEW X

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

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        NEW WD,CNT,PT,S,TOTAL,SRV,ARRAY,NUM,X,TOTAL1,LINE,FIRST,TOTAL2

 +2        KILL ^TMP("BDGCCEN",$JOB)

 +3        SET VALMCNT=0

 +4       ;

 +5       ; loop thru current inpatients by ward and count

 +6        SET WD=0

           FOR 

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

               IF WD=""

                   QUIT 

               Begin DoDot:1

 +7                SET NUM=$GET(NUM)+1

 +8                SET (CNT,PT)=0

                   FOR 

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

                       IF 'PT

                           QUIT 

                       SET CNT=CNT+1

 +9                SET ARRAY(NUM)=WD_U_CNT

                   SET TOTAL=$GET(TOTAL)+CNT

               End DoDot:1

 +10      ;

 +11      ; loop thru current inpatients by service and count

 +12       SET S=0

           FOR 

               SET S=$ORDER(^DPT("ATR",S))

               IF S=""

                   QUIT 

               Begin DoDot:1

 +13               SET (CNT,PT)=0

                   FOR 

                       SET PT=$ORDER(^DPT("ATR",S,PT))

                       IF 'PT

                           QUIT 

                       SET CNT=CNT+1

 +14               SET X=$$GET1^DIQ(45.7,S,.01)

                   IF X["OBSERVATION"

                       SET X="ZZ"_X

 +15               SET SRV(X)=CNT

                   SET TOTAL1=$GET(TOTAL1)+CNT

               End DoDot:1

 +16      ;

 +17       SET (S,NUM)=0

           FOR 

               SET S=$ORDER(SRV(S))

               IF S=""

                   QUIT 

               Begin DoDot:1

 +18      ;put observation srvs last

                   SET X=S

                   IF X["ZZ"

                       SET X=$PIECE(X,"ZZ",2)

 +19               SET NUM=NUM+1

                   SET $PIECE(ARRAY(NUM),U,3)=X_U_SRV(S)

               End DoDot:1

 +20      ;

 +21      ; take array with counts and set into display array

 +22       SET X=0

           SET FIRST=1

           FOR 

               SET X=$ORDER(ARRAY(X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +23      ;

 +24      ; separate observation services from others by a dashed line

 +25               IF $PIECE(ARRAY(X),U,3)["OBSERVATION"

                       Begin DoDot:2

 +26      ;total observations

                           SET TOTAL2=$GET(TOTAL2)+$PIECE(ARRAY(X),U,4)

 +27                       IF FIRST

                               DO SET($$SP(35)_$$REPEAT^XLFSTR("-",33),.VALMCNT)

                               SET FIRST=0

                       End DoDot:2

 +28      ;

 +29               SET LINE=$$PAD($$SP(2)_$PIECE(ARRAY(X),U),20)_$JUSTIFY($PIECE(ARRAY(X),U,2),5)

 +30               SET LINE=$$PAD(LINE,34)_$PIECE(ARRAY(X),U,3)

 +31               SET LINE=$$PAD(LINE,60)_$JUSTIFY($PIECE(ARRAY(X),U,4),5)

 +32               DO SET(LINE,.VALMCNT)

               End DoDot:1

 +33      ;

 +34      ; add totals to display array

 +35       SET LINE=$$SP(20)_$$REPEAT^XLFSTR("_",8)

 +36       SET LINE=$$PAD(LINE,60)_$$REPEAT^XLFSTR("_",8)

 +37       DO SET(LINE,.VALMCNT)

 +38      ;

 +39       SET LINE=$$PAD($$SP(20)_$JUSTIFY(+$GET(TOTAL),5),60)_$JUSTIFY(+$GET(TOTAL1),5)

 +40       DO SET(LINE,.VALMCNT)

 +41      ;

 +42      ;if have observation pt count

           IF $GET(TOTAL2)

               Begin DoDot:1

 +43               SET LINE=$$PAD($$SP(40)_"(Observation Pts =",60)_$JUSTIFY(TOTAL2,5)_"  )"

 +44               DO SET(LINE,.VALMCNT)

               End DoDot:1

 +45      ;

 +46       QUIT 

 +47      ;

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

 +1        SET NUM=NUM+1

 +2        SET ^TMP("BDGCCEN",$JOB,NUM,0)=LINE

 +3        QUIT 

 +4       ;

PRINT     ; print report to paper

 +1        NEW BDGX,BDGLN,WARD

 +2       ;U IO

 +3       ;IHS/ANMC/LJF 5/22/2002 (per Linda's LJF2 5/22/02)

           USE IO

           DO HDG

 +4       ;

 +5       ; loop thru display array

 +6        SET BDGX=0

           FOR 

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

               IF 'BDGX

                   QUIT 

               Begin DoDot:1

 +7                IF $Y>(IOSL-4)

                       DO HDG

 +8                SET BDGLN=^TMP("BDGCCEN",$JOB,BDGX,0)

 +9                WRITE !,BDGLN

               End DoDot:1

 +10       DO ^%ZISC

           DO EXIT

 +11       QUIT 

 +12      ;

HDG       ; heading for paper report

 +1       ;

 +2       ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time; centered better

 +3       ;D HDR W @IOF,?24,"Current Inpatient Census"

 +4        NEW X

           WRITE @IOF

           SET X="Current Inpatient Census for "_$$FMTE^XLFDT($$NOW^XLFDT)

           WRITE ?(80-$LENGTH(X)\2),X

 +5       ;F I=1:1 Q:'$D(VALMHDR(I))  W !,VALMHDR(I)

 +6        SET X="** "_$$CONF^BDGF_" **"

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

 +7       ;

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

 +9        WRITE !?2,"Ward",?20,"# of Pts",?34,"Service",?60,"# of Pts"

 +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("BDGCCEN",$JOB)

 +2        QUIT 

 +3       ;

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)