BDGICR2 ; IHS/ANMC/LJF - INCOMPLETE CHART BY PROVIDER ; [ 01/06/2005 11:37 AM ]
;;5.3;PIMS;**1001,1003,1005,1007**;MAY 28, 2004
;IHS/ITSC/WAR 09/27/2004 PATCH 1001 fixed call to FMDIFF^XLFDT
;IHS/ITSC/LJF 08/09/2004 PATCH 1001 observations need to print with day surgeries
; 06/02/2005 PATCH 1003 screen out "admin only" deficiencies
; 06/03/2005 PATCH 1003 improved reporting of totals
;IHS/OIT/LJF 04/06/2006 PATCH 1005 added ;EP to PROVS and EN
; 04/20/2006 PATCH 1005 added choice to print medical staff only
;cmi/anch/maw 07/10/2007 PATCH 1007 added code below to not ask for copies if subtype is terminal
; 07/10/2007 PATCH 1007 modified code in PRINT to use generic # of copies code in BDGF
;
NEW BDGTYP,X,DEFAULT,BDGPRV,BDGRPT,BDGCOP
;IHS/ITSC/LJF 8/9/2004 PATCH #1001
;S BDGTYP=$$READ^BDGF("SO^1:Inpatients Only;2:Day Surgeries Only;3:Both","Select Visit Types to Include") Q:BDGTYP<1
S BDGTYP=$$READ^BDGF("SO^1:Inpatients;2:Observations & Day Surgeries;3:All","Select Visit Types to Include") Q:BDGTYP<1
;S DEFAULT=$S(BDGTYP=1:"Discharge",BDGTYP=2:"Surgery",1:"Disch/Surg")
S DEFAULT=$S(BDGTYP=1:"Discharge",1:"Discharge/Surgery") ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
S X=$$FMADD^XLFDT(DT,-$$GET1^DIQ(9009020.1,$$DIV^BSDU,.12)) ;days delq
D MSG^BDGF("Charts with "_DEFAULT_" dates BEFORE "_$$FMTE^XLFDT(X)_" are flagged as DELINQUENT.",2,1)
S BDGPRV=$$READ^BDGF("YO","Print Report for ALL Providers","NO")
Q:BDGPRV=U S:BDGPRV=1 BDGPRV="ALL"
I BDGPRV=0 S BDGPRV=$$PROVS I '$O(BDGPRV(0)) Q
S BDGRPT=$$READ^BDGF("SO^1:Individual Provider Listings Only;2:Summary Page Only;3:Both","Select Report to Print") Q:BDGRPT<1
I $$BROWSE^BDGF="B" D EN Q
;S BDGCOP=$$READ^BDGF("N^1:10","Number of Copies (1-10)",1) Q:BDGCOP<1 ;cmi/anch/maw 7/10/2007 orig line patch 1007
I $E(IOST,1,2)'="C-" S BDGCOP=$$READ^BDGF("N^1:10","Number of Copies (1-10)",1) Q:BDGCOP<1 ;cmi/anch/maw 7/10/2007 mod line for new copies code in ZIS^BDGF patch 1007
D ZIS^BDGF("PQ","EN^BDGICR2","IC LIST BY PROVIDER","BDGTYP;BDGPRV*;BDGRPT;BDGCOP")
Q
;
EN ;EP; -- main entry point for BDG IC CHARTS BY PROVIDER
;IHS/OIT/LJF 04/06/2006 PATCH 1005 added EP - called by BDGICS21
;I $E(IOST,1,2)'="C-" S BDGPRT=1 D INIT,PRINT Q ;printing to paper
S BDGPRT=1 D INIT,PRINT Q ;printing to paper TEST
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IC CHARTS BY PROVIDER")
D CLEAR^VALM1
Q
HDR ; -- header code
Q
INIT ; -- init variables and list array
I '$G(BDGPRT) D MSG^BDGF("Please wait while I compile the list...",2,0)
NEW BDGDELQ,BDGT,I,IEN,PRV,VTYP,NAME,DATE,BDGC,BDGT,BDGPT
K ^TMP("BDGICR2",$J),^TMP("BDGICR2A",$J)
S VALMCNT=0
; set delinquent date
S BDGDELQ=$$FMADD^XLFDT(DT,-$$GET1^DIQ(9009020.1,$$DIV^BSDU,.12))
; initialize totals for summary page
;F I="ASH","OPR","SIG","SUM","IC","DQ" S BDGT(I)=0 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 not needed
; first find all provider entries that qualify and sort by name
S PRV=0 F S PRV=$O(^BDGIC("APRV",PRV)) Q:'PRV D
. I BDGPRV="SRV",'$D(BDGPRV(+$$GET1^DIQ(200,PRV,29,"I"))) Q
. I BDGPRV="CLASS",'$D(BDGPRV(+$$GET1^DIQ(200,PRV,53.5,"I"))) Q
. I BDGPRV="NAME",'$D(BDGPRV(PRV)) Q
. S IEN=0 F S IEN=$O(^BDGIC("APRV",PRV,IEN)) Q:'IEN D
.. Q:$$GET1^DIQ(9009016.1,IEN,.17)]"" ;deleted entry
.. S VTYP=$$GET1^DIQ(9009016.1,IEN,.0392) ;visit type
.. I BDGTYP=1,VTYP'["HOS" Q ;not inpt as asked
.. I BDGTYP=2,VTYP["HOS" Q ;not day surgery as asked
.. ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 skip provider if has no deficiencies to report
.. Q:'$$OKAY(PRV,IEN)
.. S NAME=$$GET1^DIQ(200,PRV,.01)
.. ;S DATE=$$GET1^DIQ(9009016.1,IEN,$S(VTYP["HOS":.02,1:.05),"I")
.. S DATE=$$GET1^DIQ(9009016.1,IEN,$S(VTYP["HOS":.02,VTYP["DAY":.05,1:.02),"I") ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
.. S:DATE="" DATE="??" S:NAME="" NAME="??"
.. S ^TMP("BDGICR2A",$J,NAME,PRV,DATE,IEN)=""
; now take sorted list and put into display array
NEW IEN,LINE,PRV,NAME,FIRST
S NAME=0,FIRST=1
F S NAME=$O(^TMP("BDGICR2A",$J,NAME)) Q:NAME="" D
. S PRV=0 F S PRV=$O(^TMP("BDGICR2A",$J,NAME,PRV)) Q:'PRV D
.. ; mark change between providers for printing to paper
.. I $G(BDGPRT),BDGRPT'=2,'FIRST D SET("@@@@@",.VALMCNT)
.. I FIRST S FIRST=0
.. ; display provider heading
.. S X=$G(IORVON)_"Incomplete Charts for "_NAME_$G(IORVOFF)
.. I BDGRPT'=2 D SET("",.VALMCNT),SET($$SP(79-$L(X)\2)_X,.VALMCNT)
.. ; initialize provider's counts
.. K BDGC F I="ASH","OPR","SIG","SUM","IC","DQ" S BDGC(I)=0
.. S DATE=0 F S DATE=$O(^TMP("BDGICR2A",$J,NAME,PRV,DATE)) Q:DATE="" D
... S IEN=0
... F S IEN=$O(^TMP("BDGICR2A",$J,NAME,PRV,DATE,IEN)) Q:'IEN D
.... ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 fix way totals are calculated
.... ; increment incomplete or delinquent list
.... ;I DATE<BDGDELQ S BDGC("DQ")=BDGC("DQ")+1,BDGT("DQ")=BDGT("DQ")+1
.... ;S BDGC("IC")=BDGC("IC")+1,BDGT("IC")=BDGT("IC")+1
.... I DATE<BDGDELQ S BDGC("DQ")=$G(BDGC("DQ"))+1,BDGT("DQ",IEN)=$G(BDGT("DQ",IEN))+1
.... S BDGC("IC")=$G(BDGC("IC"))+1,BDGT("IC",IEN)=$G(BDGT("IC",IEN))+1
.... ;end of PATCH 1003 changes
.... ; build display line
.... S LINE=$$PAD($$GET1^DIQ(9009016.1,IEN,.01),20) ;patient
.... S LINE=LINE_$J($$GET1^DIQ(9009016.1,IEN,.011),8) ;chart #
.... ;IHS/ITSC/WAR 9/27/04 PATCH #1001 PER LJF9/24
.... ;S LINE=$$PAD(LINE,30)_$$DATE(IEN) ;dsch/surg date
.... S LINE=$$PAD(LINE,30)_$$NUMDATE^BDGF(DATE\1,1) ;dsch/surg date
.... S LINE=$$PAD(LINE,40)_$$TYPE(IEN) ;hos vs ds/dso
.... ;IHS/ITSC/WAR 9/27/04 PATCH #1001 PER LJF9/24
.... ;S DAYS=$$FMDIFF^XLFDT(DT,$$IDATE(IEN)) ;# of days inc/delq
.... S DAYS=$$FMDIFF^XLFDT(DT,DATE) ;# of days inc/delq
.... ; now list unresolved deficiencies
.... S P=0 F S P=$O(^BDGIC(IEN,1,"B",PRV,P)) Q:'P D
..... Q:$$GET1^DIQ(9009016.11,P_","_IEN,.03)]"" ;resolved
..... Q:$$GET1^DIQ(9009016.11,P_","_IEN,.04)]"" ;deleted
..... ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 screen out admin only deficiencies
..... Q:$$GROUPING(P,IEN)="ADM"
..... S LINE=$$PAD(LINE,50)_$S(DATE<BDGDELQ:"*",1:" ") ;* for deliq
..... S LINE=LINE_$$GET1^DIQ(9009016.11,P_","_IEN,.02)
..... S LINE=$$PAD(LINE,72)_$J(DAYS,4) ;# days incomplete
..... I BDGRPT'=2 D SET(LINE,.VALMCNT) S LINE=""
..... ; increment grouping counts
..... S X=$$GET1^DIQ(9009016.11,P_","_IEN,.02,"I") ;chart def
..... S Y=$$GET1^DIQ(9009016.4,+X,.03,"I") ;grouping
..... ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 change way totals are counted
..... ;I Y]"" S BDGC(Y)=BDGC(Y)+1,BDGT(Y)=BDGT(Y)+1
..... I Y]"" S BDGC(Y)=$G(BDGC(Y))+1,BDGT(Y,IEN)=$G(BDGT(Y,IEN))+1
.... I BDGRPT'=2 D SET("",.VALMCNT) ;blank line between patients
.. ; at end of each provider, display summary
.. D SUMM(NAME,PRV)
I BDGRPT'=1 D TOTALS
I '$D(^TMP("BDGICR2",$J)) D SET("NO DATA FOUND",.VALMCNT)
K ^TMP("BDGICR2A",$J)
Q
DATE(IEN) ; return dates for entry (external format)
NEW X,TYPE
S TYPE=$$GET1^DIQ(9009016.1,IEN,.0392) ;visit type
I TYPE="" Q "??"
I TYPE["HOS" Q $$NUMDATE^BDGF($$GET1^DIQ(9009016.1,IEN,.02,"I")\1,1)
Q $$NUMDATE^BDGF($$GET1^DIQ(9009016.1,IEN,.05,"I")\1,1) ;surg date
IDATE(IEN) ; return dates for entry (internal format)
NEW X,TYPE
S TYPE=$$GET1^DIQ(9009016.1,IEN,.0392) ;visit type
I TYPE["HOS" Q $$GET1^DIQ(9009016.1,IEN,.02,"I")\1
Q $$GET1^DIQ(9009016.1,IEN,.05,"I")\1 ;surg date
TYPE(IEN) ; returns abbreviated visit type
NEW TYPE
S TYPE=$$GET1^DIQ(9009016.1,IEN,.0392) ;visit type
;Q $S(TYPE["HOS":"INP",TYPE["DAY":"DS",TYPE["OBS":"DSO",1:"??")
Q $S(TYPE["HOS":"INP",TYPE["DAY":"DS",TYPE["OBS":"OBS",1:"??") ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
SET(DATA,NUM) ; puts display line into list template array
S NUM=NUM+1
S ^TMP("BDGICR2",$J,NUM,0)=DATA
Q
GROUPING(X1,X2) ; return internal form of chart deficiency grouping ;IHS/ITSC/LJF 6/2/2005 PATCH 1003
Q $$GET1^DIQ(9009016.4,+$$GET1^DIQ(9009016.11,X1_","_X2,.02,"I"),.03,"I")
OKAY(PRV,IEN) ;return 1 if provider has at least one deficiency to report ;IHS/ITSC/LJF 6/2/2005 PATCH 1003
NEW P,RESULT
S (P,RESULT)=0 F S P=$O(^BDGIC(IEN,1,"B",PRV,P)) Q:'P Q:RESULT D
. Q:$$GET1^DIQ(9009016.11,P_","_IEN,.03)]"" ;resolved
. Q:$$GET1^DIQ(9009016.11,P_","_IEN,.04)]"" ;deleted
. Q:$$GROUPING(P,IEN)="ADM" ;admin only
. S RESULT=1 ;good deficiency found
Q RESULT
SUMM(NAME,PRV) ; display subcount summary for provider
NEW I,X,FIRST
F I="IC","DQ","ASH","OPR","SIG","SUM" S BDGPT(NAME,PRV,I)=BDGC(I)
Q:BDGRPT=2 ;summary page only
D SET($$SP(5)_"Total Delinquent Charts: "_BDGC("DQ"),.VALMCNT)
D SET($$SP(5)_"Total Incomplete Charts: "_BDGC("IC"),.VALMCNT)
S FIRST=1 F I="ASH","OPR","SIG","SUM" I BDGC(I)>0 D
. I FIRST S X=$$PAD($$SP(8)_"Incomplete/Delinquent for "_$P($T(@I),";;",2),55)_BDGC(I)
. E S X=$$PAD($$SP(34)_$P($T(@I),";;",2),55)_BDGC(I)
. D SET(X,.VALMCNT) S FIRST=0
D SET("",.VALMCNT)
Q
TOTALS ; display report totals on summary page
NEW LINE,NAME,PRV
; first the summary page heading
I $G(BDGPRT) D SET("@@@@@",.VALMCNT)
S X=$G(IORVON)_"SUMMARY PAGE"_$G(IORVOFF)
D SET("",.VALMCNT),SET($$SP(79-$L(X)\2)_X,.VALMCNT)
D SET("",.VALMCNT)
;IHS/ITSC/LJF 6/3/2005 PATCH 1003 enhance caption
;S LINE=$$SP(24)_"INCOMP"_$$SP(5)_"DELINQ" D SET(LINE,.VALMCNT)
S LINE=$$SP(24)_"INCOMP"_$$SP(5)_"DELINQ"_$$SP(6)_"DEFICIENCY CATEGORIES" D SET(LINE,.VALMCNT)
S LINE=$$PAD("PROVIDER",24)_"CHARTS CHARTS A SHEET OP RPT SUMM SIG"
D SET(LINE,.VALMCNT),SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
S NAME=0 F S NAME=$O(BDGPT(NAME)) Q:NAME="" D
. S PRV=0 F S PRV=$O(BDGPT(NAME,PRV)) Q:'PRV D
.. S LINE=$$PAD($E(NAME,1,20),25)
.. S LINE=LINE_$J(((BDGPT(NAME,PRV,"IC"))),3)
.. S LINE=$$PAD(LINE,38)_$J(BDGPT(NAME,PRV,"DQ"),3)
.. S LINE=$$PAD(LINE,45)_$J(BDGPT(NAME,PRV,"ASH"),3)
.. S LINE=$$PAD(LINE,53)_$J(BDGPT(NAME,PRV,"OPR"),3)
.. S LINE=$$PAD(LINE,60)_$J(BDGPT(NAME,PRV,"SUM"),3)
.. S LINE=$$PAD(LINE,67)_$J(BDGPT(NAME,PRV,"SIG"),3)
.. D SET(LINE,.VALMCNT)
;IHS/ITSC/LJF 6/3/2005 PATCH 1003 rewrote totals section
D SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
;S LINE=$$PAD($$PAD("TOTALS:",25)_$J(BDGT("IC"),3),38)_$J(BDGT("DQ"),3)
;S LINE=$$PAD($$PAD(LINE,45)_$J(BDGT("ASH"),3),53)_$J(BDGT("OPR"),3)
;S LINE=$$PAD($$PAD(LINE,60)_$J(BDGT("SUM"),3),67)_$J(BDGT("SIG"),3)
S LINE=$$PAD("# DISCHARGES:",25)
NEW PAT,CNT
S (PAT,CNT)=0 F S PAT=$O(BDGT("IC",PAT)) Q:'PAT S CNT=CNT+1 ;# incomplete charts
S LINE=$$PAD(LINE_$J(CNT,3),38)
S (PAT,CNT)=0 F S PAT=$O(BDGT("DQ",PAT)) Q:'PAT S CNT=CNT+1 ;# that are delinquent
S LINE=$$PAD(LINE_$J(CNT,3),45)
S (PAT,CNT)=0 F S PAT=$O(BDGT("ASH",PAT)) Q:'PAT S CNT=CNT+1 ;# for A Sheet deficiencies
S LINE=$$PAD(LINE_$J(CNT,3),53)
S (PAT,CNT)=0 F S PAT=$O(BDGT("OPR",PAT)) Q:'PAT S CNT=CNT+1 ;# for op report deficiencies
S LINE=$$PAD(LINE_$J(CNT,3),60)
S (PAT,CNT)=0 F S PAT=$O(BDGT("SUM",PAT)) Q:'PAT S CNT=CNT+1 ;# for disch summmary deficiencies
S LINE=$$PAD(LINE_$J(CNT,3),67)
S (PAT,CNT)=0 F S PAT=$O(BDGT("SIG",PAT)) Q:'PAT S CNT=CNT+1 ;# for A Sheet deficiencies
S LINE=LINE_$J(CNT,3)
;end of PATCH 1003 changes
D SET(LINE,.VALMCNT)
D SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
EXIT ; -- exit code
K ^TMP("BDGICR2",$J)
Q
EXPND ; -- expand code
Q
PRINT ; print report to paper
NEW BDGX,BDGLN,WARD,BDGI,BDGPG
U IO
;see 2^BDGICR for original code here, moved due to routine size limit patch 1007
;cmi/anch/maw 7/10/2007 modified below patch 1007 to adhere to new # of copies in BDGF
W @IOF ;form feed between copies
K BDGPG D INIT^BDGF,HDG ;cmi/anch/maw 7/10/2007 orig line patch 1007
;K BDGPG D INIT^BDGF ;cmi/anch/maw 7/10/2007 modified line patch 1007 to remove upfront header as it gets set in the ^TMP node
; loop thru display array
S BDGX=0 F S BDGX=$O(^TMP("BDGICR2",$J,BDGX)) Q:'BDGX D
. S BDGLN=^TMP("BDGICR2",$J,BDGX,0)
. I BDGLN="@@@@@" D HDG Q
. I $Y>(IOSL-4) D HDG
. W !,BDGLN
;cmi/anch/maw 7/10/2007 end of mods
;D ^%ZISC,PRTKL^BDGF,EXIT ;cmi/anch/maw orig 7/10/2007 patch 1007
I '$G(BDGCOP) D ^%ZISC ;cmi/anch/maw mod 7/10/2007 patch 1007
D PRTKL^BDGF,EXIT ;cmi/anch/maw mod 7/10/2007 patch 1007
Q
HDG ; heading for paper report
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGTIME,?16,$$CONF^BDGF,?76,BDGUSR
W !,BDGDATE,?24,"Incomplete Charts by Provider",?71,"Page: ",BDGPG
;IHS/ITSC/LJF 8/9/2004 PATCH #1001
NEW X S X=$S(BDGTYP=1:"Inpatients",BDGTYP=2:"Observations & Day Surgeries",1:"Inpatients, Observations & Day Surgeries")
W !?(80-$L(X)\2),X
I BDGRPT=2 W !,$$REPEAT^XLFSTR("=",80) Q ;summary page only
W !,$$REPEAT^XLFSTR("-",80)
W !?2,"Patient",?22,"HRCN",?30,"Date",?40,"Type",?50,"Deficiencies"
W ?72,"Days"
W !,$$REPEAT^XLFSTR("=",80)
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)
PROVS() ;EP select providers for report
; returns type of info in BDGPRV array
; also called by ^BDGICS5 ;IHS/OIT/LJF 04/06/2006 PATCH 1005
NEW X,Y
;IHS/OIT/LJF 0420/2006 PATCH 1005 added choice to print only med staff
;S Y=$$READ^BDGF("SO^1:For a Service;2:For a Class;3:For Providers by Name","Choose Selection Criteria") I Y<1 Q 0
S Y=$$READ^BDGF("SO^1:For a Service;2:For a Class;3:For Providers by Name;4:Medical Staff Only","Choose Selection Criteria") I Y<1 Q 0
I Y=4 D Q "NAME"
. NEW FAC S FAC=$$DIV^BSDU
. I FAC S X=0 F S X=$O(^BDGPAR(FAC,3,X)) Q:'X S BDGPRV(+^BDGPAR(FAC,3,X,0))=$$GET1^DIQ(9009020.13,X_","_FAC,.01)
S X=$S(Y=1:"SRV",Y=2:"CLASS",1:"NAME") D @X
Q X
SRV ; select providers by their hospital service designation
NEW X,Y
S Y=1 F Q:Y<1 D
. S X="Select "_$S($O(BDGPRV(0)):"Another ",1:"")_"Hospital Service Name"
. S Y=$$READ^BDGF("PO^49:EMQZ",X,"","","I $P(^DIC(49,+Y,0),U,9)=""C""")
. I Y>0 S BDGPRV(+Y)=$P(Y,U,2)
Q
CLASS ; select providers by their provider class
NEW X,Y
S Y=1 F Q:Y<1 D
. S X="Select "_$S($O(BDGPRV(0)):"Another ",1:"")_"Provider Class"
. S Y=$$READ^BDGF("PO^7:EMQZ",X)
. I Y>0 S BDGPRV(+Y)=$P(Y,U,2)
Q
NAME ; select providers by name
NEW X,Y
S Y=1 F Q:Y<1 D
. S X="Select "_$S($O(BDGPRV(0)):"Another ",1:"")_"Provider Name"
. S Y=$$READ^BDGF("PO^200:EMQZ",X,"","","I $D(^XUSEC(""PROVIDER"",+Y))")
. I Y>0 S BDGPRV(+Y)=$P(Y,U,2)
Q
GROUP ;; grouping names spelled out
ASH ;;A Sheet
OPR ;;Operative Report
SIG ;;Signature
SUM ;;Discharge Summary
BDGICR2 ; IHS/ANMC/LJF - INCOMPLETE CHART BY PROVIDER ; [ 01/06/2005 11:37 AM ]
+1 ;;5.3;PIMS;**1001,1003,1005,1007**;MAY 28, 2004
+2 ;IHS/ITSC/WAR 09/27/2004 PATCH 1001 fixed call to FMDIFF^XLFDT
+3 ;IHS/ITSC/LJF 08/09/2004 PATCH 1001 observations need to print with day surgeries
+4 ; 06/02/2005 PATCH 1003 screen out "admin only" deficiencies
+5 ; 06/03/2005 PATCH 1003 improved reporting of totals
+6 ;IHS/OIT/LJF 04/06/2006 PATCH 1005 added ;EP to PROVS and EN
+7 ; 04/20/2006 PATCH 1005 added choice to print medical staff only
+8 ;cmi/anch/maw 07/10/2007 PATCH 1007 added code below to not ask for copies if subtype is terminal
+9 ; 07/10/2007 PATCH 1007 modified code in PRINT to use generic # of copies code in BDGF
+10 ;
+11 NEW BDGTYP,X,DEFAULT,BDGPRV,BDGRPT,BDGCOP
+12 ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
+13 ;S BDGTYP=$$READ^BDGF("SO^1:Inpatients Only;2:Day Surgeries Only;3:Both","Select Visit Types to Include") Q:BDGTYP<1
+14 SET BDGTYP=$$READ^BDGF("SO^1:Inpatients;2:Observations & Day Surgeries;3:All","Select Visit Types to Include")
IF BDGTYP<1
QUIT
+15 ;S DEFAULT=$S(BDGTYP=1:"Discharge",BDGTYP=2:"Surgery",1:"Disch/Surg")
+16 ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
SET DEFAULT=$SELECT(BDGTYP=1:"Discharge",1:"Discharge/Surgery")
+17 ;days delq
SET X=$$FMADD^XLFDT(DT,-$$GET1^DIQ(9009020.1,$$DIV^BSDU,.12))
+18 DO MSG^BDGF("Charts with "_DEFAULT_" dates BEFORE "_$$FMTE^XLFDT(X)_" are flagged as DELINQUENT.",2,1)
+19 SET BDGPRV=$$READ^BDGF("YO","Print Report for ALL Providers","NO")
+20 IF BDGPRV=U
QUIT
IF BDGPRV=1
SET BDGPRV="ALL"
+21 IF BDGPRV=0
SET BDGPRV=$$PROVS
IF '$ORDER(BDGPRV(0))
QUIT
+22 SET BDGRPT=$$READ^BDGF("SO^1:Individual Provider Listings Only;2:Summary Page Only;3:Both","Select Report to Print")
IF BDGRPT<1
QUIT
+23 IF $$BROWSE^BDGF="B"
DO EN
QUIT
+24 ;S BDGCOP=$$READ^BDGF("N^1:10","Number of Copies (1-10)",1) Q:BDGCOP<1 ;cmi/anch/maw 7/10/2007 orig line patch 1007
+25 ;cmi/anch/maw 7/10/2007 mod line for new copies code in ZIS^BDGF patch 1007
IF $EXTRACT(IOST,1,2)'="C-"
SET BDGCOP=$$READ^BDGF("N^1:10","Number of Copies (1-10)",1)
IF BDGCOP<1
QUIT
+26 DO ZIS^BDGF("PQ","EN^BDGICR2","IC LIST BY PROVIDER","BDGTYP;BDGPRV*;BDGRPT;BDGCOP")
+27 QUIT
+28 ;
EN ;EP; -- main entry point for BDG IC CHARTS BY PROVIDER
+1 ;IHS/OIT/LJF 04/06/2006 PATCH 1005 added EP - called by BDGICS21
+2 ;I $E(IOST,1,2)'="C-" S BDGPRT=1 D INIT,PRINT Q ;printing to paper
+3 ;printing to paper TEST
SET BDGPRT=1
DO INIT
DO PRINT
QUIT
+4 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+5 DO EN^VALM("BDG IC CHARTS BY PROVIDER")
+6 DO CLEAR^VALM1
+7 QUIT
HDR ; -- header code
+1 QUIT
INIT ; -- init variables and list array
+1 IF '$GET(BDGPRT)
DO MSG^BDGF("Please wait while I compile the list...",2,0)
+2 NEW BDGDELQ,BDGT,I,IEN,PRV,VTYP,NAME,DATE,BDGC,BDGT,BDGPT
+3 KILL ^TMP("BDGICR2",$JOB),^TMP("BDGICR2A",$JOB)
+4 SET VALMCNT=0
+5 ; set delinquent date
+6 SET BDGDELQ=$$FMADD^XLFDT(DT,-$$GET1^DIQ(9009020.1,$$DIV^BSDU,.12))
+7 ; initialize totals for summary page
+8 ;F I="ASH","OPR","SIG","SUM","IC","DQ" S BDGT(I)=0 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 not needed
+9 ; first find all provider entries that qualify and sort by name
+10 SET PRV=0
FOR
SET PRV=$ORDER(^BDGIC("APRV",PRV))
IF 'PRV
QUIT
Begin DoDot:1
+11 IF BDGPRV="SRV"
IF '$DATA(BDGPRV(+$$GET1^DIQ(200,PRV,29,"I")))
QUIT
+12 IF BDGPRV="CLASS"
IF '$DATA(BDGPRV(+$$GET1^DIQ(200,PRV,53.5,"I")))
QUIT
+13 IF BDGPRV="NAME"
IF '$DATA(BDGPRV(PRV))
QUIT
+14 SET IEN=0
FOR
SET IEN=$ORDER(^BDGIC("APRV",PRV,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+15 ;deleted entry
IF $$GET1^DIQ(9009016.1,IEN,.17)]""
QUIT
+16 ;visit type
SET VTYP=$$GET1^DIQ(9009016.1,IEN,.0392)
+17 ;not inpt as asked
IF BDGTYP=1
IF VTYP'["HOS"
QUIT
+18 ;not day surgery as asked
IF BDGTYP=2
IF VTYP["HOS"
QUIT
+19 ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 skip provider if has no deficiencies to report
+20 IF '$$OKAY(PRV,IEN)
QUIT
+21 SET NAME=$$GET1^DIQ(200,PRV,.01)
+22 ;S DATE=$$GET1^DIQ(9009016.1,IEN,$S(VTYP["HOS":.02,1:.05),"I")
+23 ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
SET DATE=$$GET1^DIQ(9009016.1,IEN,$SELECT(VTYP["HOS":.02,VTYP["DAY":.05,1:.02),"I")
+24 IF DATE=""
SET DATE="??"
IF NAME=""
SET NAME="??"
+25 SET ^TMP("BDGICR2A",$JOB,NAME,PRV,DATE,IEN)=""
End DoDot:2
End DoDot:1
+26 ; now take sorted list and put into display array
+27 NEW IEN,LINE,PRV,NAME,FIRST
+28 SET NAME=0
SET FIRST=1
+29 FOR
SET NAME=$ORDER(^TMP("BDGICR2A",$JOB,NAME))
IF NAME=""
QUIT
Begin DoDot:1
+30 SET PRV=0
FOR
SET PRV=$ORDER(^TMP("BDGICR2A",$JOB,NAME,PRV))
IF 'PRV
QUIT
Begin DoDot:2
+31 ; mark change between providers for printing to paper
+32 IF $GET(BDGPRT)
IF BDGRPT'=2
IF 'FIRST
DO SET("@@@@@",.VALMCNT)
+33 IF FIRST
SET FIRST=0
+34 ; display provider heading
+35 SET X=$GET(IORVON)_"Incomplete Charts for "_NAME_$GET(IORVOFF)
+36 IF BDGRPT'=2
DO SET("",.VALMCNT)
DO SET($$SP(79-$LENGTH(X)\2)_X,.VALMCNT)
+37 ; initialize provider's counts
+38 KILL BDGC
FOR I="ASH","OPR","SIG","SUM","IC","DQ"
SET BDGC(I)=0
+39 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGICR2A",$JOB,NAME,PRV,DATE))
IF DATE=""
QUIT
Begin DoDot:3
+40 SET IEN=0
+41 FOR
SET IEN=$ORDER(^TMP("BDGICR2A",$JOB,NAME,PRV,DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+42 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 fix way totals are calculated
+43 ; increment incomplete or delinquent list
+44 ;I DATE<BDGDELQ S BDGC("DQ")=BDGC("DQ")+1,BDGT("DQ")=BDGT("DQ")+1
+45 ;S BDGC("IC")=BDGC("IC")+1,BDGT("IC")=BDGT("IC")+1
+46 IF DATE<BDGDELQ
SET BDGC("DQ")=$GET(BDGC("DQ"))+1
SET BDGT("DQ",IEN)=$GET(BDGT("DQ",IEN))+1
+47 SET BDGC("IC")=$GET(BDGC("IC"))+1
SET BDGT("IC",IEN)=$GET(BDGT("IC",IEN))+1
+48 ;end of PATCH 1003 changes
+49 ; build display line
+50 ;patient
SET LINE=$$PAD($$GET1^DIQ(9009016.1,IEN,.01),20)
+51 ;chart #
SET LINE=LINE_$JUSTIFY($$GET1^DIQ(9009016.1,IEN,.011),8)
+52 ;IHS/ITSC/WAR 9/27/04 PATCH #1001 PER LJF9/24
+53 ;S LINE=$$PAD(LINE,30)_$$DATE(IEN) ;dsch/surg date
+54 ;dsch/surg date
SET LINE=$$PAD(LINE,30)_$$NUMDATE^BDGF(DATE\1,1)
+55 ;hos vs ds/dso
SET LINE=$$PAD(LINE,40)_$$TYPE(IEN)
+56 ;IHS/ITSC/WAR 9/27/04 PATCH #1001 PER LJF9/24
+57 ;S DAYS=$$FMDIFF^XLFDT(DT,$$IDATE(IEN)) ;# of days inc/delq
+58 ;# of days inc/delq
SET DAYS=$$FMDIFF^XLFDT(DT,DATE)
+59 ; now list unresolved deficiencies
+60 SET P=0
FOR
SET P=$ORDER(^BDGIC(IEN,1,"B",PRV,P))
IF 'P
QUIT
Begin DoDot:5
+61 ;resolved
IF $$GET1^DIQ(9009016.11,P_","_IEN,.03)]""
QUIT
+62 ;deleted
IF $$GET1^DIQ(9009016.11,P_","_IEN,.04)]""
QUIT
+63 ;IHS/ITSC/LJF 6/2/2005 PATCH 1003 screen out admin only deficiencies
+64 IF $$GROUPING(P,IEN)="ADM"
QUIT
+65 ;* for deliq
SET LINE=$$PAD(LINE,50)_$SELECT(DATE<BDGDELQ:"*",1:" ")
+66 SET LINE=LINE_$$GET1^DIQ(9009016.11,P_","_IEN,.02)
+67 ;# days incomplete
SET LINE=$$PAD(LINE,72)_$JUSTIFY(DAYS,4)
+68 IF BDGRPT'=2
DO SET(LINE,.VALMCNT)
SET LINE=""
+69 ; increment grouping counts
+70 ;chart def
SET X=$$GET1^DIQ(9009016.11,P_","_IEN,.02,"I")
+71 ;grouping
SET Y=$$GET1^DIQ(9009016.4,+X,.03,"I")
+72 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 change way totals are counted
+73 ;I Y]"" S BDGC(Y)=BDGC(Y)+1,BDGT(Y)=BDGT(Y)+1
+74 IF Y]""
SET BDGC(Y)=$GET(BDGC(Y))+1
SET BDGT(Y,IEN)=$GET(BDGT(Y,IEN))+1
End DoDot:5
+75 ;blank line between patients
IF BDGRPT'=2
DO SET("",.VALMCNT)
End DoDot:4
End DoDot:3
+76 ; at end of each provider, display summary
+77 DO SUMM(NAME,PRV)
End DoDot:2
End DoDot:1
+78 IF BDGRPT'=1
DO TOTALS
+79 IF '$DATA(^TMP("BDGICR2",$JOB))
DO SET("NO DATA FOUND",.VALMCNT)
+80 KILL ^TMP("BDGICR2A",$JOB)
+81 QUIT
DATE(IEN) ; return dates for entry (external format)
+1 NEW X,TYPE
+2 ;visit type
SET TYPE=$$GET1^DIQ(9009016.1,IEN,.0392)
+3 IF TYPE=""
QUIT "??"
+4 IF TYPE["HOS"
QUIT $$NUMDATE^BDGF($$GET1^DIQ(9009016.1,IEN,.02,"I")\1,1)
+5 ;surg date
QUIT $$NUMDATE^BDGF($$GET1^DIQ(9009016.1,IEN,.05,"I")\1,1)
IDATE(IEN) ; return dates for entry (internal format)
+1 NEW X,TYPE
+2 ;visit type
SET TYPE=$$GET1^DIQ(9009016.1,IEN,.0392)
+3 IF TYPE["HOS"
QUIT $$GET1^DIQ(9009016.1,IEN,.02,"I")\1
+4 ;surg date
QUIT $$GET1^DIQ(9009016.1,IEN,.05,"I")\1
TYPE(IEN) ; returns abbreviated visit type
+1 NEW TYPE
+2 ;visit type
SET TYPE=$$GET1^DIQ(9009016.1,IEN,.0392)
+3 ;Q $S(TYPE["HOS":"INP",TYPE["DAY":"DS",TYPE["OBS":"DSO",1:"??")
+4 ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
QUIT $SELECT(TYPE["HOS":"INP",TYPE["DAY":"DS",TYPE["OBS":"OBS",1:"??")
SET(DATA,NUM) ; puts display line into list template array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGICR2",$JOB,NUM,0)=DATA
+3 QUIT
GROUPING(X1,X2) ; return internal form of chart deficiency grouping ;IHS/ITSC/LJF 6/2/2005 PATCH 1003
+1 QUIT $$GET1^DIQ(9009016.4,+$$GET1^DIQ(9009016.11,X1_","_X2,.02,"I"),.03,"I")
OKAY(PRV,IEN) ;return 1 if provider has at least one deficiency to report ;IHS/ITSC/LJF 6/2/2005 PATCH 1003
+1 NEW P,RESULT
+2 SET (P,RESULT)=0
FOR
SET P=$ORDER(^BDGIC(IEN,1,"B",PRV,P))
IF 'P
QUIT
IF RESULT
QUIT
Begin DoDot:1
+3 ;resolved
IF $$GET1^DIQ(9009016.11,P_","_IEN,.03)]""
QUIT
+4 ;deleted
IF $$GET1^DIQ(9009016.11,P_","_IEN,.04)]""
QUIT
+5 ;admin only
IF $$GROUPING(P,IEN)="ADM"
QUIT
+6 ;good deficiency found
SET RESULT=1
End DoDot:1
+7 QUIT RESULT
SUMM(NAME,PRV) ; display subcount summary for provider
+1 NEW I,X,FIRST
+2 FOR I="IC","DQ","ASH","OPR","SIG","SUM"
SET BDGPT(NAME,PRV,I)=BDGC(I)
+3 ;summary page only
IF BDGRPT=2
QUIT
+4 DO SET($$SP(5)_"Total Delinquent Charts: "_BDGC("DQ"),.VALMCNT)
+5 DO SET($$SP(5)_"Total Incomplete Charts: "_BDGC("IC"),.VALMCNT)
+6 SET FIRST=1
FOR I="ASH","OPR","SIG","SUM"
IF BDGC(I)>0
Begin DoDot:1
+7 IF FIRST
SET X=$$PAD($$SP(8)_"Incomplete/Delinquent for "_$PIECE($TEXT(@I),";;",2),55)_BDGC(I)
+8 IF '$TEST
SET X=$$PAD($$SP(34)_$PIECE($TEXT(@I),";;",2),55)_BDGC(I)
+9 DO SET(X,.VALMCNT)
SET FIRST=0
End DoDot:1
+10 DO SET("",.VALMCNT)
+11 QUIT
TOTALS ; display report totals on summary page
+1 NEW LINE,NAME,PRV
+2 ; first the summary page heading
+3 IF $GET(BDGPRT)
DO SET("@@@@@",.VALMCNT)
+4 SET X=$GET(IORVON)_"SUMMARY PAGE"_$GET(IORVOFF)
+5 DO SET("",.VALMCNT)
DO SET($$SP(79-$LENGTH(X)\2)_X,.VALMCNT)
+6 DO SET("",.VALMCNT)
+7 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 enhance caption
+8 ;S LINE=$$SP(24)_"INCOMP"_$$SP(5)_"DELINQ" D SET(LINE,.VALMCNT)
+9 SET LINE=$$SP(24)_"INCOMP"_$$SP(5)_"DELINQ"_$$SP(6)_"DEFICIENCY CATEGORIES"
DO SET(LINE,.VALMCNT)
+10 SET LINE=$$PAD("PROVIDER",24)_"CHARTS CHARTS A SHEET OP RPT SUMM SIG"
+11 DO SET(LINE,.VALMCNT)
DO SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
+12 SET NAME=0
FOR
SET NAME=$ORDER(BDGPT(NAME))
IF NAME=""
QUIT
Begin DoDot:1
+13 SET PRV=0
FOR
SET PRV=$ORDER(BDGPT(NAME,PRV))
IF 'PRV
QUIT
Begin DoDot:2
+14 SET LINE=$$PAD($EXTRACT(NAME,1,20),25)
+15 SET LINE=LINE_$JUSTIFY(((BDGPT(NAME,PRV,"IC"))),3)
+16 SET LINE=$$PAD(LINE,38)_$JUSTIFY(BDGPT(NAME,PRV,"DQ"),3)
+17 SET LINE=$$PAD(LINE,45)_$JUSTIFY(BDGPT(NAME,PRV,"ASH"),3)
+18 SET LINE=$$PAD(LINE,53)_$JUSTIFY(BDGPT(NAME,PRV,"OPR"),3)
+19 SET LINE=$$PAD(LINE,60)_$JUSTIFY(BDGPT(NAME,PRV,"SUM"),3)
+20 SET LINE=$$PAD(LINE,67)_$JUSTIFY(BDGPT(NAME,PRV,"SIG"),3)
+21 DO SET(LINE,.VALMCNT)
End DoDot:2
End DoDot:1
+22 ;IHS/ITSC/LJF 6/3/2005 PATCH 1003 rewrote totals section
+23 DO SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
+24 ;S LINE=$$PAD($$PAD("TOTALS:",25)_$J(BDGT("IC"),3),38)_$J(BDGT("DQ"),3)
+25 ;S LINE=$$PAD($$PAD(LINE,45)_$J(BDGT("ASH"),3),53)_$J(BDGT("OPR"),3)
+26 ;S LINE=$$PAD($$PAD(LINE,60)_$J(BDGT("SUM"),3),67)_$J(BDGT("SIG"),3)
+27 SET LINE=$$PAD("# DISCHARGES:",25)
+28 NEW PAT,CNT
+29 ;# incomplete charts
SET (PAT,CNT)=0
FOR
SET PAT=$ORDER(BDGT("IC",PAT))
IF 'PAT
QUIT
SET CNT=CNT+1
+30 SET LINE=$$PAD(LINE_$JUSTIFY(CNT,3),38)
+31 ;# that are delinquent
SET (PAT,CNT)=0
FOR
SET PAT=$ORDER(BDGT("DQ",PAT))
IF 'PAT
QUIT
SET CNT=CNT+1
+32 SET LINE=$$PAD(LINE_$JUSTIFY(CNT,3),45)
+33 ;# for A Sheet deficiencies
SET (PAT,CNT)=0
FOR
SET PAT=$ORDER(BDGT("ASH",PAT))
IF 'PAT
QUIT
SET CNT=CNT+1
+34 SET LINE=$$PAD(LINE_$JUSTIFY(CNT,3),53)
+35 ;# for op report deficiencies
SET (PAT,CNT)=0
FOR
SET PAT=$ORDER(BDGT("OPR",PAT))
IF 'PAT
QUIT
SET CNT=CNT+1
+36 SET LINE=$$PAD(LINE_$JUSTIFY(CNT,3),60)
+37 ;# for disch summmary deficiencies
SET (PAT,CNT)=0
FOR
SET PAT=$ORDER(BDGT("SUM",PAT))
IF 'PAT
QUIT
SET CNT=CNT+1
+38 SET LINE=$$PAD(LINE_$JUSTIFY(CNT,3),67)
+39 ;# for A Sheet deficiencies
SET (PAT,CNT)=0
FOR
SET PAT=$ORDER(BDGT("SIG",PAT))
IF 'PAT
QUIT
SET CNT=CNT+1
+40 SET LINE=LINE_$JUSTIFY(CNT,3)
+41 ;end of PATCH 1003 changes
+42 DO SET(LINE,.VALMCNT)
+43 DO SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
+44 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
EXIT ; -- exit code
+1 KILL ^TMP("BDGICR2",$JOB)
+2 QUIT
EXPND ; -- expand code
+1 QUIT
PRINT ; print report to paper
+1 NEW BDGX,BDGLN,WARD,BDGI,BDGPG
+2 USE IO
+3 ;see 2^BDGICR for original code here, moved due to routine size limit patch 1007
+4 ;cmi/anch/maw 7/10/2007 modified below patch 1007 to adhere to new # of copies in BDGF
+5 ;form feed between copies
WRITE @IOF
+6 ;cmi/anch/maw 7/10/2007 orig line patch 1007
KILL BDGPG
DO INIT^BDGF
DO HDG
+7 ;K BDGPG D INIT^BDGF ;cmi/anch/maw 7/10/2007 modified line patch 1007 to remove upfront header as it gets set in the ^TMP node
+8 ; loop thru display array
+9 SET BDGX=0
FOR
SET BDGX=$ORDER(^TMP("BDGICR2",$JOB,BDGX))
IF 'BDGX
QUIT
Begin DoDot:1
+10 SET BDGLN=^TMP("BDGICR2",$JOB,BDGX,0)
+11 IF BDGLN="@@@@@"
DO HDG
QUIT
+12 IF $Y>(IOSL-4)
DO HDG
+13 WRITE !,BDGLN
End DoDot:1
+14 ;cmi/anch/maw 7/10/2007 end of mods
+15 ;D ^%ZISC,PRTKL^BDGF,EXIT ;cmi/anch/maw orig 7/10/2007 patch 1007
+16 ;cmi/anch/maw mod 7/10/2007 patch 1007
IF '$GET(BDGCOP)
DO ^%ZISC
+17 ;cmi/anch/maw mod 7/10/2007 patch 1007
DO PRTKL^BDGF
DO EXIT
+18 QUIT
HDG ; heading for paper report
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGTIME,?16,$$CONF^BDGF,?76,BDGUSR
+3 WRITE !,BDGDATE,?24,"Incomplete Charts by Provider",?71,"Page: ",BDGPG
+4 ;IHS/ITSC/LJF 8/9/2004 PATCH #1001
+5 NEW X
SET X=$SELECT(BDGTYP=1:"Inpatients",BDGTYP=2:"Observations & Day Surgeries",1:"Inpatients, Observations & Day Surgeries")
+6 WRITE !?(80-$LENGTH(X)\2),X
+7 ;summary page only
IF BDGRPT=2
WRITE !,$$REPEAT^XLFSTR("=",80)
QUIT
+8 WRITE !,$$REPEAT^XLFSTR("-",80)
+9 WRITE !?2,"Patient",?22,"HRCN",?30,"Date",?40,"Type",?50,"Deficiencies"
+10 WRITE ?72,"Days"
+11 WRITE !,$$REPEAT^XLFSTR("=",80)
+12 QUIT
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
PROVS() ;EP select providers for report
+1 ; returns type of info in BDGPRV array
+2 ; also called by ^BDGICS5 ;IHS/OIT/LJF 04/06/2006 PATCH 1005
+3 NEW X,Y
+4 ;IHS/OIT/LJF 0420/2006 PATCH 1005 added choice to print only med staff
+5 ;S Y=$$READ^BDGF("SO^1:For a Service;2:For a Class;3:For Providers by Name","Choose Selection Criteria") I Y<1 Q 0
+6 SET Y=$$READ^BDGF("SO^1:For a Service;2:For a Class;3:For Providers by Name;4:Medical Staff Only","Choose Selection Criteria")
IF Y<1
QUIT 0
+7 IF Y=4
Begin DoDot:1
+8 NEW FAC
SET FAC=$$DIV^BSDU
+9 IF FAC
SET X=0
FOR
SET X=$ORDER(^BDGPAR(FAC,3,X))
IF 'X
QUIT
SET BDGPRV(+^BDGPAR(FAC,3,X,0))=$$GET1^DIQ(9009020.13,X_","_FAC,.01)
End DoDot:1
QUIT "NAME"
+10 SET X=$SELECT(Y=1:"SRV",Y=2:"CLASS",1:"NAME")
DO @X
+11 QUIT X
SRV ; select providers by their hospital service designation
+1 NEW X,Y
+2 SET Y=1
FOR
IF Y<1
QUIT
Begin DoDot:1
+3 SET X="Select "_$SELECT($ORDER(BDGPRV(0)):"Another ",1:"")_"Hospital Service Name"
+4 SET Y=$$READ^BDGF("PO^49:EMQZ",X,"","","I $P(^DIC(49,+Y,0),U,9)=""C""")
+5 IF Y>0
SET BDGPRV(+Y)=$PIECE(Y,U,2)
End DoDot:1
+6 QUIT
CLASS ; select providers by their provider class
+1 NEW X,Y
+2 SET Y=1
FOR
IF Y<1
QUIT
Begin DoDot:1
+3 SET X="Select "_$SELECT($ORDER(BDGPRV(0)):"Another ",1:"")_"Provider Class"
+4 SET Y=$$READ^BDGF("PO^7:EMQZ",X)
+5 IF Y>0
SET BDGPRV(+Y)=$PIECE(Y,U,2)
End DoDot:1
+6 QUIT
NAME ; select providers by name
+1 NEW X,Y
+2 SET Y=1
FOR
IF Y<1
QUIT
Begin DoDot:1
+3 SET X="Select "_$SELECT($ORDER(BDGPRV(0)):"Another ",1:"")_"Provider Name"
+4 SET Y=$$READ^BDGF("PO^200:EMQZ",X,"","","I $D(^XUSEC(""PROVIDER"",+Y))")
+5 IF Y>0
SET BDGPRV(+Y)=$PIECE(Y,U,2)
End DoDot:1
+6 QUIT
GROUP ;; grouping names spelled out
ASH ;;A Sheet
OPR ;;Operative Report
SIG ;;Signature
SUM ;;Discharge Summary
