BDGIPL5.m

BDGIPL5 ; IHS/ANMC/LJF - CURR INPTS BY SRV & PROV ;  

 ;;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 PROVIDER

 ; assumes BDGSRT and BDGSRT1 are set

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

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

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

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

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

 S X=X_" / "_$S(BDGSRT1="A":"For ALL Providers",1:$P(BDGSRT1,U,2))

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

 I $G(BDGSRT2) D

 . S X=$S(BDGSRT2=1:"Inpatients Only",BDGSRT2=2:"Observations Only",1:"")

 . I X]"" S VALMHDR(3)=$$SP(75-$L(X)\2)_X

 Q

 ;

INIT ; -- init variables and list array

 NEW BDGSRV,BDGSVN,BDGCNT,SRV,PROV,LINE,DFN,X

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

 S VALMCNT=0,BDGCNT=1

 ;11/1/O2 WAR - following change per P37 LJF30

 ;IHS/ANMC/LJF 10/31/2002 add ability to print >1 service

 ;S BDGSRV=$S(BDGSRT="A":0,1:+BDGSRT)

 ;I BDGSRV S BDGSVN=$P(BDGSRT,U,2) D PATLOOP,TRANSFER I 1  ;one service

 ;

 ; if user asked for all services

 ;E  F  S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV  D

 I '$D(BDGSRT2) S BDGSRT2=""

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

 . I BDGSRT=0,'$D(BDGSRT(BDGSRV)) Q       ;not in list of selected services

 . ;IHS/ANMC/LJF 10/31/2002 end of mods

 . S BDGSVN=$$GET1^DIQ(45.7,BDGSRV,.01)   ;service name

 . I BDGSRT2=1,BDGSVN["OBSERVATION" Q     ;inpt only

 . I BDGSRT2=2,BDGSVN'["OBSERVATION" Q    ;observation only

 . D PATLOOP,TRANSFER

 ;

 ; pull sorted list and create display array

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

 . ;

 . ; set up service name subheading

 . I SRV'["**" D SET($G(IORVON)_SRV_$G(IORVOFF),.VALMCNT,BDGCNT,"")

 . ;

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

 .. ;

 .. ; if SRV contains "**" means list of transfers out of service

 .. I SRV["**" D

 ... S X="Admitted to "_$P(SRV,"**")_" ("_PROV_")"_" then tranferred:"

 ... D SET(X,.VALMCNT,BDGCNT,"")

 .. ;

 .. ; set up provider subheading

 .. E  D

 ... S X=$$SP(3)_$G(IORVON)_PROV_$G(IORVOFF)

 ... D SET(X,.VALMCNT,BDGCNT,"")

 .. ;

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

 ... ;

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

 ... S LINE=LINE_$E($$GET1^DIQ(2,DFN,.01),1,20)  ;patient

 ... S LINE=$$PAD(LINE,27)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)     ;chart#

 ... S LINE=$$PAD(LINE,36)_$$GET1^DIQ(9000001,DFN,1102.98)    ;age

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

 ... S LINE=$$PAD(LINE,47)_$E($$GET1^DIQ(9000001,DFN,1118),1,15)  ;comm

 ... S LINE=$$PAD(LINE,64)_$E($$CURDX^BDGF1(DFN),1,16)        ;adm dx

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

 ... ; 

 ... S LINE=$$SP(10)_"Admitted: "

 ... S LINE=LINE_$P($$INPT1^BDGF1(DFN,DT),":",1,2)            ;admit dt

 ... S LINE=LINE_" ("_$$CURLOS^BDGF1(DFN,1)_")"               ;los

 ... S LINE=$$PAD(LINE,50)_$$WRDABRV^BDGF1(DFN)_" Ward"       ;ward

 ... S X=$G(^DPT(DFN,.101)) I X]"" S LINE=LINE_" ("_X_")"     ;room-bed

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

 ... ;

 ... ; if transferred, display date and new service

 ... S X=^TMP("BDGIPL1",$J,SRV,PROV,DFN) I X]"" D

 .... S LINE=$$SP(12)_"To "_$$GET1^DIQ(2,DFN,.103)

 .... S LINE=LINE_" ("_$$CURPRV^BDGF1(DFN,32)_")"

 .... S LINE=LINE_" on "_$P(X,":",1,2)

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

 ... ;

 ... D SET("",.VALMCNT,BDGCNT,DFN)  ;blank line between patients

 ... ; increment counter

 ... S BDGCNT=BDGCNT+1

 .. ;

 .. ; skip line between services

 .. I $O(^TMP("BDGIPL1",$J,SRV,PROV))="" D SET("",.VALMCNT,BDGCNT,"")

 ;

 K ^TMP("BDGIPL1",$J)

 Q

 ;

PATLOOP ; loop by dfn then sort results by provider

 NEW DFN,X

 Q:BDGSVN=""   ;in case of incomplete admissions in file

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

 . S X=$$CURPRV^BDGF1(DFN) I X="" S X="??"

 . I BDGSRT1,(X'=$P(BDGSRT1,U,2)) Q   ;not provider selected

 . S ^TMP("BDGIPL1",$J,BDGSVN,X,DFN)=""

 Q

 ;

TRANSFER ; returns new service and date if transferred from admtg service

 NEW CA,SRV,DATE,X,DFN

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

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

 .. S CA=$G(^DPT(DFN,.105))                          ;admission ien

 .. S SRV=$$ADMSRV^BDGF1(CA,DFN) S:SRV="" SRV="??"   ;admission service

 .. ;

 .. ; if adm service not equal current service, continue

 .. I SRV'=$$GET1^DIQ(2,DFN,.103) D

 ... ;11/1/O2 WAR - following change per P37 LJF30

 ... ;IHS/ANMC/LJF 10/31/2002 check array of sevices

 ... ;I BDGSRT'="A" Q:SRV'=BDGSVN  ;not looking for this service

 ... I BDGSRT'="A" NEW X S X=$O(^DIC(45.7,"B",SRV,0)) Q:'X  I '$D(BDGSRT(X)) Q

 ... ;IHS/ANMC/LJF 10/31/2002 end of mods

 ... I BDGSRT="A",$G(BDGSRT2)=2 Q:SRV'["OBSERVATION"

 ... S DATE=$$GET1^DIQ(405,+$$LASTTXN^BDGF1(CA,DFN),.01)   ;transf date

 ... ;

 ... ; subscript is adm service

 ... S X=$$ADMPRV^BDGF1(CA,DFN,"PRM") S:X="" X="??"   ;primary inpt prv

 ... S ^TMP("BDGIPL1",$J,SRV_"**",X,DFN)=DATE

 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,BDGPG

 U IO D INIT^BDGF,HDG

 ;

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

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

 . W !,^TMP("BDGIPL",$J,BDGX,0)

 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/11/2007 was appended to previous line PATCH 1007

 ;

HDG ; heading for paper report

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

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

 W !,BDGDATE,?20,"Current Inpatients by Service/Provider"

 ;11/1/O2 WAR - following change per P37 LJF30

 ;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2))  ;IHS/ANMC/LJF 10/31/2002

 S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS)          ;IHS/ANMC/LJF 10/31/2002

 W ?70,"Page: ",BDGPG

 S X=X_$S(BDGSRT1="A":" / For ALL Providers",1:$P(BDGSRT1,U,2))

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

 I $G(BDGSRT2) D

 . S X=$S(BDGSRT2=1:"Inpatients",BDGSRT2=2:"Observations",1:"")

 . I X]"" S X="("_X_" Only)" W !?(80-$L(X)\2),X

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

 W !?5,"Patient Name",?27,"Chart #",?36,"Age",?43,"Sex  Community"

 W ?64,"Admitting Dx"

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

 Q

 ;

HELP ; -- help code

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

 Q

 ;

EXIT ; -- exit code

 K ^TMP("BDGIPL",$J)

 ;K BDGSRT,BDGSRT1,DGPMIFN  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)

 ;

 ;11/1/O2 WAR - following change per P37 LJF30

SERVS() ; returns service name or "selected services";IHS/ANMC/LJF 10/31/2002

 NEW X

 S X=$O(BDGSRT(0)) I $O(BDGSRT(X)) Q "Selected Services"

 Q BDGSRT(X)

BDGIPL5   ; IHS/ANMC/LJF - CURR INPTS BY SRV & PROV ;  

 +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        IF $EXTRACT(IOST,1,2)="P-"

               DO INIT

               DO PRINT

               QUIT 

 +7       ;

EN        ; -- main entry point for BDG IPL BY PROVIDER

 +1       ; assumes BDGSRT and BDGSRT1 are set

 +2        NEW VALMCNT

           DO TERM^VALM0

           DO CLEAR^VALM1

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

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

 +4        SET X=X_" / "_$SELECT(BDGSRT1="A":"For ALL Providers",1:$PIECE(BDGSRT1,U,2))

 +5        SET VALMHDR(2)=$$SP(79-$LENGTH(X)\2)_X

 +6        IF $GET(BDGSRT2)

               Begin DoDot:1

 +7                SET X=$SELECT(BDGSRT2=1:"Inpatients Only",BDGSRT2=2:"Observations Only",1:"")

 +8                IF X]""

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

               End DoDot:1

 +9        QUIT 

 +10      ;

INIT      ; -- init variables and list array

 +1        NEW BDGSRV,BDGSVN,BDGCNT,SRV,PROV,LINE,DFN,X

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

 +3        SET VALMCNT=0

           SET BDGCNT=1

 +4       ;11/1/O2 WAR - following change per P37 LJF30

 +5       ;IHS/ANMC/LJF 10/31/2002 add ability to print >1 service

 +6       ;S BDGSRV=$S(BDGSRT="A":0,1:+BDGSRT)

 +7       ;I BDGSRV S BDGSVN=$P(BDGSRT,U,2) D PATLOOP,TRANSFER I 1  ;one service

 +8       ;

 +9       ; if user asked for all services

 +10      ;E  F  S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV  D

 +11       IF '$DATA(BDGSRT2)

               SET BDGSRT2=""

 +12       SET BDGSRV=0

           FOR 

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

               IF 'BDGSRV

                   QUIT 

               Begin DoDot:1

 +13      ;not in list of selected services

                   IF BDGSRT=0

                       IF '$DATA(BDGSRT(BDGSRV))

                           QUIT 

 +14      ;IHS/ANMC/LJF 10/31/2002 end of mods

 +15      ;service name

                   SET BDGSVN=$$GET1^DIQ(45.7,BDGSRV,.01)

 +16      ;inpt only

                   IF BDGSRT2=1

                       IF BDGSVN["OBSERVATION"

                           QUIT 

 +17      ;observation only

                   IF BDGSRT2=2

                       IF BDGSVN'["OBSERVATION"

                           QUIT 

 +18               DO PATLOOP

                   DO TRANSFER

               End DoDot:1

 +19      ;

 +20      ; pull sorted list and create display array

 +21       SET SRV=0

           FOR 

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

               IF SRV=""

                   QUIT 

               Begin DoDot:1

 +22      ;

 +23      ; set up service name subheading

 +24               IF SRV'["**"

                       DO SET($GET(IORVON)_SRV_$GET(IORVOFF),.VALMCNT,BDGCNT,"")

 +25      ;

 +26               SET PROV=0

                   FOR 

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

                       IF PROV=""

                           QUIT 

                       Begin DoDot:2

 +27      ;

 +28      ; if SRV contains "**" means list of transfers out of service

 +29                       IF SRV["**"

                               Begin DoDot:3

 +30                               SET X="Admitted to "_$PIECE(SRV,"**")_" ("_PROV_")"_" then tranferred:"

 +31                               DO SET(X,.VALMCNT,BDGCNT,"")

                               End DoDot:3

 +32      ;

 +33      ; set up provider subheading

 +34                      IF '$TEST

                               Begin DoDot:3

 +35                               SET X=$$SP(3)_$GET(IORVON)_PROV_$GET(IORVOFF)

 +36                               DO SET(X,.VALMCNT,BDGCNT,"")

                               End DoDot:3

 +37      ;

 +38                       SET DFN=0

                           FOR 

                               SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,SRV,PROV,DFN))

                               IF 'DFN

                                   QUIT 

                               Begin DoDot:3

 +39      ;

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

 +41      ;patient

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

 +42      ;chart#

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

 +43      ;age

                                   SET LINE=$$PAD(LINE,36)_$$GET1^DIQ(9000001,DFN,1102.98)

 +44      ;sex

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

 +45      ;comm

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

 +46      ;adm dx

                                   SET LINE=$$PAD(LINE,64)_$EXTRACT($$CURDX^BDGF1(DFN),1,16)

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

 +48      ; 

 +49                               SET LINE=$$SP(10)_"Admitted: "

 +50      ;admit dt

                                   SET LINE=LINE_$PIECE($$INPT1^BDGF1(DFN,DT),":",1,2)

 +51      ;los

                                   SET LINE=LINE_" ("_$$CURLOS^BDGF1(DFN,1)_")"

 +52      ;ward

                                   SET LINE=$$PAD(LINE,50)_$$WRDABRV^BDGF1(DFN)_" Ward"

 +53      ;room-bed

                                   SET X=$GET(^DPT(DFN,.101))

                                   IF X]""

                                       SET LINE=LINE_" ("_X_")"

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

 +55      ;

 +56      ; if transferred, display date and new service

 +57                               SET X=^TMP("BDGIPL1",$JOB,SRV,PROV,DFN)

                                   IF X]""

                                       Begin DoDot:4

 +58                                       SET LINE=$$SP(12)_"To "_$$GET1^DIQ(2,DFN,.103)

 +59                                       SET LINE=LINE_" ("_$$CURPRV^BDGF1(DFN,32)_")"

 +60                                       SET LINE=LINE_" on "_$PIECE(X,":",1,2)

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

                                       End DoDot:4

 +62      ;

 +63      ;blank line between patients

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

 +64      ; increment counter

 +65                               SET BDGCNT=BDGCNT+1

                               End DoDot:3

 +66      ;

 +67      ; skip line between services

 +68                       IF $ORDER(^TMP("BDGIPL1",$JOB,SRV,PROV))=""

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

                       End DoDot:2

               End DoDot:1

 +69      ;

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

 +71       QUIT 

 +72      ;

PATLOOP   ; loop by dfn then sort results by provider

 +1        NEW DFN,X

 +2       ;in case of incomplete admissions in file

           IF BDGSVN=""

               QUIT 

 +3        SET DFN=0

           FOR 

               SET DFN=$ORDER(^DPT("ATR",BDGSRV,DFN))

               IF 'DFN

                   QUIT 

               Begin DoDot:1

 +4                SET X=$$CURPRV^BDGF1(DFN)

                   IF X=""

                       SET X="??"

 +5       ;not provider selected

                   IF BDGSRT1

                       IF (X'=$PIECE(BDGSRT1,U,2))

                           QUIT 

 +6                SET ^TMP("BDGIPL1",$JOB,BDGSVN,X,DFN)=""

               End DoDot:1

 +7        QUIT 

 +8       ;

TRANSFER  ; returns new service and date if transferred from admtg service

 +1        NEW CA,SRV,DATE,X,DFN

 +2        SET WARD=0

           FOR 

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

               IF WARD=""

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

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

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4       ;admission ien

                           SET CA=$GET(^DPT(DFN,.105))

 +5       ;admission service

                           SET SRV=$$ADMSRV^BDGF1(CA,DFN)

                           IF SRV=""

                               SET SRV="??"

 +6       ;

 +7       ; if adm service not equal current service, continue

 +8                        IF SRV'=$$GET1^DIQ(2,DFN,.103)

                               Begin DoDot:3

 +9       ;11/1/O2 WAR - following change per P37 LJF30

 +10      ;IHS/ANMC/LJF 10/31/2002 check array of sevices

 +11      ;I BDGSRT'="A" Q:SRV'=BDGSVN  ;not looking for this service

 +12                               IF BDGSRT'="A"

                                       NEW X

                                       SET X=$ORDER(^DIC(45.7,"B",SRV,0))

                                       IF 'X

                                           QUIT 

                                       IF '$DATA(BDGSRT(X))

                                           QUIT 

 +13      ;IHS/ANMC/LJF 10/31/2002 end of mods

 +14                               IF BDGSRT="A"

                                       IF $GET(BDGSRT2)=2

                                           IF SRV'["OBSERVATION"

                                               QUIT 

 +15      ;transf date

                                   SET DATE=$$GET1^DIQ(405,+$$LASTTXN^BDGF1(CA,DFN),.01)

 +16      ;

 +17      ; subscript is adm service

 +18      ;primary inpt prv

                                   SET X=$$ADMPRV^BDGF1(CA,DFN,"PRM")

                                   IF X=""

                                       SET X="??"

 +19                               SET ^TMP("BDGIPL1",$JOB,SRV_"**",X,DFN)=DATE

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +20       QUIT 

 +21      ;

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,BDGPG

 +2        USE IO

           DO INIT^BDGF

           DO HDG

 +3       ;

 +4        SET BDGX=0

           FOR 

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

               IF 'BDGX

                   QUIT 

               Begin DoDot:1

 +5                IF $Y>(IOSL-4)

                       DO HDG

 +6                WRITE !,^TMP("BDGIPL",$JOB,BDGX,0)

               End DoDot:1

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

 +8        DO PRTKL^BDGF

           DO EXIT

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

 +10      ;cmi/anch/maw 7/11/2007 was appended to previous line PATCH 1007

           QUIT 

 +11      ;

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,?20,"Current Inpatients by Service/Provider"

 +4       ;11/1/O2 WAR - following change per P37 LJF30

 +5       ;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2))  ;IHS/ANMC/LJF 10/31/2002

 +6       ;IHS/ANMC/LJF 10/31/2002

           SET X=$SELECT(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS)

 +7        WRITE ?70,"Page: ",BDGPG

 +8        SET X=X_$SELECT(BDGSRT1="A":" / For ALL Providers",1:$PIECE(BDGSRT1,U,2))

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

 +10       IF $GET(BDGSRT2)

               Begin DoDot:1

 +11               SET X=$SELECT(BDGSRT2=1:"Inpatients",BDGSRT2=2:"Observations",1:"")

 +12               IF X]""

                       SET X="("_X_" Only)"

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

               End DoDot:1

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

 +14       WRITE !?5,"Patient Name",?27,"Chart #",?36,"Age",?43,"Sex  Community"

 +15       WRITE ?64,"Admitting Dx"

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

 +17       QUIT 

 +18      ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

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

 +2       ;K BDGSRT,BDGSRT1,DGPMIFN  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       ;

 +3       ;11/1/O2 WAR - following change per P37 LJF30

SERVS()   ; returns service name or "selected services";IHS/ANMC/LJF 10/31/2002

 +1        NEW X

 +2        SET X=$ORDER(BDGSRT(0))

           IF $ORDER(BDGSRT(X))

               QUIT "Selected Services"

 +3        QUIT BDGSRT(X)