BDGICR4 ; IHS/ANMC/LJF - CODED A SHEET REPORTS ;
;;5.3;PIMS;**1009,1010**;APR 26, 2002
;
;cmi/anch/maw 02/19/2009 PATCH 1009 requirement 67 in GATHER
;
D ^XBCLS
D MSG^BDGF($$SP(20)_"CODED A SHEET REPORTS",2,2)
NEW Y S Y=$$READ^BDGF("SO^1:WITH DATE CODED;2:WITH DATE EXPORTED","Select CODED A SHEET REPORT") Q:'Y I +Y=1 D ^BDGICR41 Q
;
NEW BDGED,BDGBD
S BDGBD=$$READ^BDGF("DO^::E","Select BEGINNING Discharge Date")
Q:BDGBD<1
S BDGED=$$READ^BDGF("DO^::E","Select ENDING Discharge Date")
Q:BDGED<1
D ZIS^BDGF("PQ","EN^BDGICR4","EXPORTED A SHEETS","BDGBD;BDGED")
Q
;
EN ;EP; -- main entry point for BDG IC DATE EXPORTED
NEW VALMCNT
I IOST'["C-" D GATHER(BDGBD,BDGED),PRINT Q
D TERM^VALM0
D EN^VALM("BDG IC DATE EXPORTED")
Q
;
HDR ;EP; -- header code
S VALMHDR(1)=$$SP(20)_$$CONF^BDGF
Q
;
INIT ;EP; -- init variables and list array
NEW BDGLN
D MSG^BDGF("Building/Updating Display. . .Please wait.",2,0)
D GATHER(BDGBD,BDGED)
S VALMCNT=BDGLN
Q
;
HELP ;EP; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;EP; -- exit code
K ^TMP("BDGICR4",$J) K BDGLN
Q
;
EXIT2 ;EP; -- exit code for patient listing
K VALMCNT Q
;
EXPND ; -- expand code
Q
;
GATHER(BDGBD,BDGED) ; -- create display array
NEW DATE,VH,VST,DATA,DFN,NAME,BDGTOT,BDGETOT,LINE,VDT
K ^TMP("BDGICR4",$J),^TMP("BDGICR4A",$J)
;
; loop through hospitalizations by date and sort by date then name
S DATE=BDGBD-.0001,BDGLN=0
F S DATE=$O(^AUPNVINP("B",DATE)) Q:'DATE!(DATE>(BDGED+.24)) D
. S VH=0 F S VH=$O(^AUPNVINP("B",DATE,VH)) Q:'VH D
.. ;
.. Q:'$D(^AUPNVINP(VH,0)) S VST=$P(^(0),U,3)
.. Q:$P(^AUPNVINP(VH,0),U,15)'="" ;check coded flag
.. Q:'$D(^AUPNVSIT(VST,0)) S DATA=^(0)
.. Q:$P(DATA,U,11)'="" ;screen out deleted visits
.. Q:$P(DATA,U,6)'=DUZ(2) ;screen out other facilities
.. S DFN=$P(DATA,U,5),NAME=$P(^DPT(DFN,0),U),VDT=$P(DATA,U)
.. S ^TMP("BDGICR4A",$J,$P(DATE,"."),NAME,DFN,VH)=VST_U_VDT
;
; loop through sorted list and put into display array
S DATE=0,(BDGTOT,BDGETOT)=0
F S DATE=$O(^TMP("BDGICR4A",$J,DATE)) Q:'DATE D
. ;
. D SET("",.BDGLN),SET($$SP(20)_"DISCHARGED ON: "_$$DATE(DATE),.BDGLN)
. ;
. S NAME=0 F S NAME=$O(^TMP("BDGICR4A",$J,DATE,NAME)) Q:NAME="" D
.. S DFN=0 F S DFN=$O(^TMP("BDGICR4A",$J,DATE,NAME,DFN)) Q:'DFN D
... S VH=0 F S VH=$O(^TMP("BDGICR4A",$J,DATE,NAME,DFN,VH)) Q:'VH D
.... ;
.... S DATA=^TMP("BDGICR4A",$J,DATE,NAME,DFN,VH)
.... S VST=+DATA,VDT=$P(DATA,U,2),BDGTOT=BDGTOT+1
.... S HRCN=$$HRCN^BDGF2(DFN,DUZ(2))
.... S LINE=" "_$$PAD($E(NAME,1,20),26)_$J(HRCN,6) ;name & chart #
.... S LINE=$$PAD(LINE,40)_$$DATE(VDT) ;admit date
.... S LINE=$$PAD(LINE,52)_$$DATE($$GET1^DIQ(9000010,VST,.13,"I")) ;mod
.... ;S Y=$$GET1^DIQ(9000010,VST,.14,"I") I Y]"" S BDGETOT=BDGETOT+1 ;cmi/maw 2/19/2008 orig line PATCH 1009 requirement 67
.... S Y=$$GET1^DIQ(9000010,VST,1106,"I") I Y]"" S BDGETOT=BDGETOT+1 ;cmi/maw 2/19/2008 PATCH 1008 requirement 67
.... I Y S LINE=$$PAD(LINE,64)_$$DATE(Y) ;date exported
.... D SET(LINE,.BDGLN)
;
S LINE=$$SP(5)_"Total Coded: "_BDGTOT
S LINE=$$PAD(LINE,40)_"Total Exported: "_BDGETOT
D SET("",.BDGLN),SET(LINE,.BDGLN)
;
K ^TMP("BDGICR4A",$J)
Q
;
SET(LINE,BDGLN) ; -- sets ^tmp
S BDGLN=BDGLN+1
S ^TMP("BDGICR4",$J,BDGLN,0)=LINE
Q
;
;
PRINT ; -- print lists to paper
NEW BDGX,BDGL,BDGPG
U IO D INIT^BDGF,HDG
;
S BDGL=0 F S BDGL=$O(^TMP("BDGICR4",$J,BDGL)) Q:'BDGL D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGICR4",$J,BDGL,0)
;
D ^%ZISC,PRTKL^BDGF,EXIT
Q
;
HDG ; heading when printing to paper
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?16,$$CONF^BDGF
W !,BDGDATE,?25,"CODED A SHEETS WITH EXPORT DATE",?71,"Page: ",BDGPG
NEW X S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !,"Patient Name",?27,"Chart #",?40,"Admitted",?52,"Modified"
W ?64,"Exported",!,$$REPEAT^XLFSTR("=",80)
Q
;
;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(NUM) ; -- SUBRTN to pad spaces
Q $$PAD(" ",NUM)
;
DATE(X) ; -- returns date in readable format
NEW Y S Y=$$FMTE^XLFDT(X,"2DF")
Q $TR(Y," ","0")
BDGICR4 ; IHS/ANMC/LJF - CODED A SHEET REPORTS ;
+1 ;;5.3;PIMS;**1009,1010**;APR 26, 2002
+2 ;
+3 ;cmi/anch/maw 02/19/2009 PATCH 1009 requirement 67 in GATHER
+4 ;
+5 DO ^XBCLS
+6 DO MSG^BDGF($$SP(20)_"CODED A SHEET REPORTS",2,2)
+7 NEW Y
SET Y=$$READ^BDGF("SO^1:WITH DATE CODED;2:WITH DATE EXPORTED","Select CODED A SHEET REPORT")
IF 'Y
QUIT
IF +Y=1
DO ^BDGICR41
QUIT
+8 ;
+9 NEW BDGED,BDGBD
+10 SET BDGBD=$$READ^BDGF("DO^::E","Select BEGINNING Discharge Date")
+11 IF BDGBD<1
QUIT
+12 SET BDGED=$$READ^BDGF("DO^::E","Select ENDING Discharge Date")
+13 IF BDGED<1
QUIT
+14 DO ZIS^BDGF("PQ","EN^BDGICR4","EXPORTED A SHEETS","BDGBD;BDGED")
+15 QUIT
+16 ;
EN ;EP; -- main entry point for BDG IC DATE EXPORTED
+1 NEW VALMCNT
+2 IF IOST'["C-"
DO GATHER(BDGBD,BDGED)
DO PRINT
QUIT
+3 DO TERM^VALM0
+4 DO EN^VALM("BDG IC DATE EXPORTED")
+5 QUIT
+6 ;
HDR ;EP; -- header code
+1 SET VALMHDR(1)=$$SP(20)_$$CONF^BDGF
+2 QUIT
+3 ;
INIT ;EP; -- init variables and list array
+1 NEW BDGLN
+2 DO MSG^BDGF("Building/Updating Display. . .Please wait.",2,0)
+3 DO GATHER(BDGBD,BDGED)
+4 SET VALMCNT=BDGLN
+5 QUIT
+6 ;
HELP ;EP; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;EP; -- exit code
+1 KILL ^TMP("BDGICR4",$JOB)
KILL BDGLN
+2 QUIT
+3 ;
EXIT2 ;EP; -- exit code for patient listing
+1 KILL VALMCNT
QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GATHER(BDGBD,BDGED) ; -- create display array
+1 NEW DATE,VH,VST,DATA,DFN,NAME,BDGTOT,BDGETOT,LINE,VDT
+2 KILL ^TMP("BDGICR4",$JOB),^TMP("BDGICR4A",$JOB)
+3 ;
+4 ; loop through hospitalizations by date and sort by date then name
+5 SET DATE=BDGBD-.0001
SET BDGLN=0
+6 FOR
SET DATE=$ORDER(^AUPNVINP("B",DATE))
IF 'DATE!(DATE>(BDGED+.24))
QUIT
Begin DoDot:1
+7 SET VH=0
FOR
SET VH=$ORDER(^AUPNVINP("B",DATE,VH))
IF 'VH
QUIT
Begin DoDot:2
+8 ;
+9 IF '$DATA(^AUPNVINP(VH,0))
QUIT
SET VST=$PIECE(^(0),U,3)
+10 ;check coded flag
IF $PIECE(^AUPNVINP(VH,0),U,15)'=""
QUIT
+11 IF '$DATA(^AUPNVSIT(VST,0))
QUIT
SET DATA=^(0)
+12 ;screen out deleted visits
IF $PIECE(DATA,U,11)'=""
QUIT
+13 ;screen out other facilities
IF $PIECE(DATA,U,6)'=DUZ(2)
QUIT
+14 SET DFN=$PIECE(DATA,U,5)
SET NAME=$PIECE(^DPT(DFN,0),U)
SET VDT=$PIECE(DATA,U)
+15 SET ^TMP("BDGICR4A",$JOB,$PIECE(DATE,"."),NAME,DFN,VH)=VST_U_VDT
End DoDot:2
End DoDot:1
+16 ;
+17 ; loop through sorted list and put into display array
+18 SET DATE=0
SET (BDGTOT,BDGETOT)=0
+19 FOR
SET DATE=$ORDER(^TMP("BDGICR4A",$JOB,DATE))
IF 'DATE
QUIT
Begin DoDot:1
+20 ;
+21 DO SET("",.BDGLN)
DO SET($$SP(20)_"DISCHARGED ON: "_$$DATE(DATE),.BDGLN)
+22 ;
+23 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGICR4A",$JOB,DATE,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+24 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGICR4A",$JOB,DATE,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+25 SET VH=0
FOR
SET VH=$ORDER(^TMP("BDGICR4A",$JOB,DATE,NAME,DFN,VH))
IF 'VH
QUIT
Begin DoDot:4
+26 ;
+27 SET DATA=^TMP("BDGICR4A",$JOB,DATE,NAME,DFN,VH)
+28 SET VST=+DATA
SET VDT=$PIECE(DATA,U,2)
SET BDGTOT=BDGTOT+1
+29 SET HRCN=$$HRCN^BDGF2(DFN,DUZ(2))
+30 ;name & chart #
SET LINE=" "_$$PAD($EXTRACT(NAME,1,20),26)_$JUSTIFY(HRCN,6)
+31 ;admit date
SET LINE=$$PAD(LINE,40)_$$DATE(VDT)
+32 ;mod
SET LINE=$$PAD(LINE,52)_$$DATE($$GET1^DIQ(9000010,VST,.13,"I"))
+33 ;S Y=$$GET1^DIQ(9000010,VST,.14,"I") I Y]"" S BDGETOT=BDGETOT+1 ;cmi/maw 2/19/2008 orig line PATCH 1009 requirement 67
+34 ;cmi/maw 2/19/2008 PATCH 1008 requirement 67
SET Y=$$GET1^DIQ(9000010,VST,1106,"I")
IF Y]""
SET BDGETOT=BDGETOT+1
+35 ;date exported
IF Y
SET LINE=$$PAD(LINE,64)_$$DATE(Y)
+36 DO SET(LINE,.BDGLN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 SET LINE=$$SP(5)_"Total Coded: "_BDGTOT
+39 SET LINE=$$PAD(LINE,40)_"Total Exported: "_BDGETOT
+40 DO SET("",.BDGLN)
DO SET(LINE,.BDGLN)
+41 ;
+42 KILL ^TMP("BDGICR4A",$JOB)
+43 QUIT
+44 ;
SET(LINE,BDGLN) ; -- sets ^tmp
+1 SET BDGLN=BDGLN+1
+2 SET ^TMP("BDGICR4",$JOB,BDGLN,0)=LINE
+3 QUIT
+4 ;
+5 ;
PRINT ; -- print lists to paper
+1 NEW BDGX,BDGL,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 ;
+4 SET BDGL=0
FOR
SET BDGL=$ORDER(^TMP("BDGICR4",$JOB,BDGL))
IF 'BDGL
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGICR4",$JOB,BDGL,0)
End DoDot:1
+7 ;
+8 DO ^%ZISC
DO PRTKL^BDGF
DO EXIT
+9 QUIT
+10 ;
HDG ; heading when printing to paper
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?16,$$CONF^BDGF
+3 WRITE !,BDGDATE,?25,"CODED A SHEETS WITH EXPORT DATE",?71,"Page: ",BDGPG
+4 NEW X
SET X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
+5 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+6 WRITE !,$$REPEAT^XLFSTR("-",80)
+7 WRITE !,"Patient Name",?27,"Chart #",?40,"Admitted",?52,"Modified"
+8 WRITE ?64,"Exported",!,$$REPEAT^XLFSTR("=",80)
+9 QUIT
+10 ;
+11 ;
PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(NUM) ; -- SUBRTN to pad spaces
+1 QUIT $$PAD(" ",NUM)
+2 ;
DATE(X) ; -- returns date in readable format
+1 NEW Y
SET Y=$$FMTE^XLFDT(X,"2DF")
+2 QUIT $TRANSLATE(Y," ","0")
