Routine: BDGOPL

BDGOPL ; IHS/ANMC/LJF - OPERATORS' LIST OF INPATIENTS ;  [ 08/12/2003  3:58 PM ]

 ;;5.3;PIMS;;APR 26, 2002

 I $$BROWSE^BDGF="B" D EN Q

 D ZIS^BDGF("QP","EN^BDGOPL","OPERATORS' LIST","")

EN ; -- main entry point for BDG OPERATORS' LIST

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

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG OPERATORS' LIST")

 D CLEAR^VALM1

HDR ; -- header code

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

INIT ; -- init variables and list array

 NEW WD,DFN,BDGCNT,NAME

 K ^TMP("BDGOPL",$J),^TMP("BDGOPL1",$J)

 S VALMCNT=0,BDGCNT=1

 ; loop thru inpatients and put in alphabetical order

 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 ^TMP("BDGOPL1",$J,$$GET1^DIQ(2,DFN,.01),DFN)=""

 ; pull sorted list and create display array

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

 . S DFN=0 F  S DFN=$O(^TMP("BDGOPL1",$J,NM,DFN)) Q:'DFN  D

 .. D LINE

 K ^TMP("BDGOPL1",$J)

LINE ; set up dislay line for patient

 NEW LINE,X

 S LINE=$E($$GET1^DIQ(2,DFN,.01),1,23)  ;name

 I $$OPTOUT^BDGF1(DFN) S LINE=$$REPEAT^XLFSTR("*",20)   ;if patient opted out of directory;IHS/ITSC/LJF 10/03/2003

 S LINE=$$PAD(LINE,25)_$$PHONE                                ;rm phone

 S LINE=$$PAD(LINE,33)_$G(^DPT(DFN,.101))                     ;room

 S LINE=$$PAD(LINE,42)_$$WRDABRV^BDGF1(DFN)                   ;ward

 S LINE=$$PAD(LINE,50)_$$GET1^DIQ(2,DFN,.02,"I")              ;sex

 S LINE=$$PAD(LINE,55)_$J($$GET1^DIQ(9000001,DFN,1102.98),7)  ;age

 S LINE=$$PAD(LINE,65)_$E($$GET1^DIQ(9000001,DFN,1118),1,15)  ;commun

 D SET(LINE,.VALMCNT)

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

 S NUM=NUM+1

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

PRINT ; print report to paper

 NEW BDGX,BDGLN,BDGPG

 U IO D HDG

 ; loop thru display array

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

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

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

 . W !,BDGLN

 D ^%ZISC,EXIT

HDG ; heading for paper report

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

 W !?16,$$CONF^BDGF,?67,$$FMTE^XLFDT(DT)

 W !?28,"Operators' Inpatient List",?70,$J($$TIME^BDGF($$NOW^XLFDT),9)

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

 W !,"Patient",?25,"Phone",?33,"Room",?42,"Ward",?49,"Sex"

 W ?57,"Age",?65,"Community"

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

PHONE() ; returns room phone number if asked for

 NEW X,ROOM

 S ROOM=$G(^DPT(DFN,.101)) I ROOM="" Q ""

 S X=$O(^DG(405.4,"B",ROOM,0)) I 'X Q ""

 S X=$$GET1^DIQ(405.4,X,9999999.01)

 Q $S(X]"":"x"_X,1:"")

HELP ; -- help code

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

EXIT ; -- exit code

 K ^TMP("BDGOPL",$J)

 K BDGSRT

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)

BDGOPL    ; IHS/ANMC/LJF - OPERATORS' LIST OF INPATIENTS ;  [ 08/12/2003  3:58 PM ]

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

 +3        IF $$BROWSE^BDGF="B"

               DO EN

               QUIT

 +4        DO ZIS^BDGF("QP","EN^BDGOPL","OPERATORS' LIST","")

 +5        QUIT

 +6       ;

EN        ; -- main entry point for BDG OPERATORS' LIST

 +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 OPERATORS' LIST")

 +4        DO CLEAR^VALM1

 +5        QUIT

 +6       ;

HDR       ; -- header code

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

 +2        QUIT

 +3       ;

INIT      ; -- init variables and list array

 +1        NEW WD,DFN,BDGCNT,NAME

 +2        KILL ^TMP("BDGOPL",$JOB),^TMP("BDGOPL1",$JOB)

 +3        SET VALMCNT=0

           SET BDGCNT=1

 +4       ;

 +5       ; loop thru inpatients and put in alphabetical order

 +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                        SET ^TMP("BDGOPL1",$JOB,$$GET1^DIQ(2,DFN,.01),DFN)=""

                       End DoDot:2

               End DoDot:1

 +9       ;

 +10      ; pull sorted list and create display array

 +11       SET NM=0

FOR

               SET NM=$ORDER(^TMP("BDGOPL1",$JOB,NM))

               IF NM=""

                   QUIT

               Begin DoDot:1

 +12               SET DFN=0

FOR

                       SET DFN=$ORDER(^TMP("BDGOPL1",$JOB,NM,DFN))

                       IF 'DFN

                           QUIT

                       Begin DoDot:2

 +13                       DO LINE

                       End DoDot:2

               End DoDot:1

 +14      ;

 +15       KILL ^TMP("BDGOPL1",$JOB)

 +16       QUIT

 +17      ;

LINE      ; set up dislay line for patient

 +1        NEW LINE,X

 +2       ;

 +3       ;name

           SET LINE=$EXTRACT($$GET1^DIQ(2,DFN,.01),1,23)

 +4       ;if patient opted out of directory;IHS/ITSC/LJF 10/03/2003

           IF $$OPTOUT^BDGF1(DFN)

               SET LINE=$$REPEAT^XLFSTR("*",20)

 +5       ;

 +6       ;rm phone

           SET LINE=$$PAD(LINE,25)_$$PHONE

 +7       ;room

           SET LINE=$$PAD(LINE,33)_$GET(^DPT(DFN,.101))

 +8       ;ward

           SET LINE=$$PAD(LINE,42)_$$WRDABRV^BDGF1(DFN)

 +9       ;sex

           SET LINE=$$PAD(LINE,50)_$$GET1^DIQ(2,DFN,.02,"I")

 +10      ;age

           SET LINE=$$PAD(LINE,55)_$JUSTIFY($$GET1^DIQ(9000001,DFN,1102.98),7)

 +11      ;commun

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

 +12       DO SET(LINE,.VALMCNT)

 +13       QUIT

 +14      ;

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

 +1        SET NUM=NUM+1

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

 +3        QUIT

 +4       ;

PRINT     ; print report to paper

 +1        NEW BDGX,BDGLN,BDGPG

 +2        USE IO

           DO HDG

 +3       ;

 +4       ; loop thru display array

 +5        SET BDGX=0

FOR

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

               IF 'BDGX

                   QUIT

               Begin DoDot:1

 +6                IF $Y>(IOSL-4)

                       DO HDG

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

 +8                WRITE !,BDGLN

               End DoDot:1

 +9       ;

 +10       DO ^%ZISC

           DO EXIT

 +11       QUIT

 +12      ;

HDG       ; heading for paper report

 +1       ;page #

           SET BDGPG=$GET(BDGPG)+1

           IF BDGPG>1

               WRITE @IOF

 +2        WRITE !?16,$$CONF^BDGF,?67,$$FMTE^XLFDT(DT)

 +3        WRITE !?28,"Operators' Inpatient List",?70,$JUSTIFY($$TIME^BDGF($$NOW^XLFDT),9)

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

 +5        WRITE !,"Patient",?25,"Phone",?33,"Room",?42,"Ward",?49,"Sex"

 +6        WRITE ?57,"Age",?65,"Community"

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

 +8        QUIT

 +9       ;

PHONE()   ; returns room phone number if asked for

 +1        NEW X,ROOM

 +2        SET ROOM=$GET(^DPT(DFN,.101))

           IF ROOM=""

               QUIT ""

 +3        SET X=$ORDER(^DG(405.4,"B",ROOM,0))

           IF 'X

               QUIT ""

 +4        SET X=$$GET1^DIQ(405.4,X,9999999.01)

 +5        QUIT $SELECT(X]"":"x"_X,1:"")

 +6       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

EXIT      ; -- exit code

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

 +2        KILL BDGSRT

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

BDGOPL.m