IBERS3 ;ALB/ARH - APPOINTMENT CHECK-OFF SHEET GENERATOR (CONTINUED); 12/6/91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;gather data continued - dx's
;first three DXs from patients PTF records (by discharge date) and billing records (by event date) for the last year
;with a max of 18 (IBPDN), first 3 DX's from the last 6 records in year
;input: DFN, IBDT
;
S IBFD="",IBPDN=18
PTFDX ;701 dx's for last year, or at most 3 dx's from last 6 ptf's
S (IBST,IBADT)=(IBDT-10000),IBEND=(IBDT+.99)
;get last years pft records, store in reverse cronological order by discharge date
F S IBADT=$O(^DGPT("AAD",DFN,IBADT)) Q:IBADT=""!(IBADT>IBEND) S IBPTF="" D
. F S IBPTF=$O(^DGPT("AAD",DFN,IBADT,IBPTF)) Q:IBPTF="" D
.. S IBN=$G(^DGPT(IBPTF,70)) Q:IBN=""!(+IBN>IBEND) S IBG(-IBN,IBPTF)=IBN
G:'$D(IBG) ENDPTF S IBDXP1=10,IBDXP2=16,IBDXP3=17,IBCNT=0
D DX G:'$D(IBD) ENDPTF
D DX1 G:'$D(IBTMP) ENDPTF S IBLBL="Discharge"
D DX2
ENDPTF K IBADT,IBCNT,IBPTF,IBST,IBEND,IBN
;
BILLDX ;print billing dx's, or at most 3 dx's from last 6 bills
S (IBST,IBEG)=(IBDT-10000),IBEND=(IBDT+.99),IBBN=""
;get last years billing records, store in reverse cronological order by event date
F S IBBN=$O(^DGCR(399,"C",DFN,IBBN)) Q:IBBN="" D
. S IBEDT=$P($G(^DGCR(399,IBBN,0)),"^",3) Q:(IBEDT>IBEND)!(IBEDT<IBEG)
. S IBN=$G(^DGCR(399,IBBN,"C")) Q:IBN="" S IBG(-IBEDT,IBBN)=IBN
G:'$D(IBG) ENDBILL S IBDXP1=14,IBDXP2=15,IBDXP3=16,IBCNT=0
D DX G:'$D(IBD) ENDBILL
D DX1 G:'$D(IBTMP) ENDBILL S IBLBL="Billing" S IBX="" D ENDLN
D DX2
ENDBILL K IBN,IBCNT,IBST,IBEDT,IBEND,IBEG,IBX,IBBN
;
END I IBFD S IBX=IBDSH D ENDLN
K IBFD,IBPDN
Q
;
DX ;get appropriate number of DX codes from choosen records
S IBDDT="" F S IBDDT=$O(IBG(IBDDT)) Q:IBDDT=""!(IBPDN'>IBCNT) D
. S IBX="" F S IBX=$O(IBG(IBDDT,IBX)) Q:IBX=""!(IBPDN'>IBCNT) S IBN=IBG(IBDDT,IBX) D
.. F IBI=IBDXP1,IBDXP2,IBDXP3 S IBDX=$P(IBN,"^",IBI) I IBDX,(IBPDN>IBCNT),'($G(IBR($E(IBDDT,1,7),IBDX))) D
... S IBCNT=IBCNT+1,IBD(IBDDT,IBCNT)=IBDX_"^"_$S(IBI=10:"*",1:" ") I IBCNT=IBPDN S IBST=-IBDDT
... S IBR($E(IBDDT,1,7),IBDX)=1
K IBDDT,IBX,IBI,IBDX,IBN,IBR,IBG,IBDXP1,IBDXP2,IBDXP3,IBX
Q
;
;format records found that have dx's in past year (from previous steps)
DX1 S IBFD=1,IBDDT="",IBROW=1,IBCOL=3,IBRMAX=(IBCNT\IBCOL)+$S(IBCNT#IBCOL=0:0,1:1)
;format dx's for printing, 3 columns, descending date
F S IBDDT=$O(IBD(IBDDT)) Q:IBDDT="" S IBX="" F S IBX=$O(IBD(IBDDT,IBX)) Q:IBX="" D
. S IBDX=IBD(IBDDT,IBX),IBDDTE=$$DAT1^IBOUTL(-IBDDT)
. S IBDX=IBDDTE_" "_$P(IBDX,"^",2)_"("_$J($P($G(^ICD9(+IBDX,0)),"^",1),7)_") "_$P($G(^ICD9(+IBDX,0)),"^",3)
. I IBROW>IBRMAX S IBROW=1,IBCOL=IBCOL-1,IBRMAX=(IBCNT\IBCOL)+$S(IBCNT#IBCOL=0:0,1:1)
. S IBTMP(IBROW)=$S($D(IBTMP(IBROW)):IBTMP(IBROW),1:$J("",IB1))_$E(IBDX,1,IB3)_$J("",(IB3-$L(IBDX)))_$J("",IB4)
. S IBROW=IBROW+1,IBCNT=IBCNT-1
K IBDDT,IBROW,IBCOL,IBRMAX,IBX,IBDX,IBD,IBDDTE
Q
;
;set results into temp array to be printed on check-off sheet
DX2 S Y=IBST X ^DD("DD") S IBEG=$P(Y,"@",1),Y=IBDT X ^DD("DD") S IBEND=$P(Y,"@",1)
S IBX=IBLBL_" Diagnosis for "_IBEG_" to "_IBEND,IBW=1 D LINE S IBX="" D ENDLN
S IBDX="" F S IBDX=$O(IBTMP(IBDX)) Q:IBDX="" S IBX=$E(IBTMP(IBDX),1,IOM) D ENDLN
K Y,IBEG,IBEND,IBX,IBDX,IBTMP,IBLBL
Q
;
;enters a line into the temp file used to had the COS before printing
LINE ;prints 1 (IBW=1) 2 (IBW=2) or three (IBW=3) pieces of data on a formated line
;use IBW=1 for headers centered on the page: IBX=header text
;entry at lable ENDLN can be used to insert a line with no additional formating
I IBW=1 S IBT=IB1+(IB2-($L(IBX)/2)),IBX=$J("",IBT)_IBX G ENDLN
S IBL=$S(IBW=2:IB2,1:IB3),IBT=IB4
S IBX=$E(IBX,1,IBL),IBX=$J("",IB1)_IBX_$J("",(IBL-$L(IBX)))
S IBY=$E(IBY,1,IBL),IBX=IBX_$J("",IBT)_IBY_$J("",(IBL-$L(IBY)))
I IBW=3 S IBZ=$E(IBZ,1,IBL),IBX=IBX_$J("",IBT)_IBZ_$J("",(IBL-$L(IBZ)))
ENDLN S IBLC=IBLC+1,^TMP("IBRSP",$J,IBLC)=IBX
K IBT,IBL
Q
IBERS3 ;ALB/ARH - APPOINTMENT CHECK-OFF SHEET GENERATOR (CONTINUED); 12/6/91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;gather data continued - dx's
+4 ;first three DXs from patients PTF records (by discharge date) and billing records (by event date) for the last year
+5 ;with a max of 18 (IBPDN), first 3 DX's from the last 6 records in year
+6 ;input: DFN, IBDT
+7 ;
+8 SET IBFD=""
SET IBPDN=18
PTFDX ;701 dx's for last year, or at most 3 dx's from last 6 ptf's
+1 SET (IBST,IBADT)=(IBDT-10000)
SET IBEND=(IBDT+.99)
+2 ;get last years pft records, store in reverse cronological order by discharge date
+3 FOR
SET IBADT=$ORDER(^DGPT("AAD",DFN,IBADT))
IF IBADT=""!(IBADT>IBEND)
QUIT
SET IBPTF=""
Begin DoDot:1
+4 FOR
SET IBPTF=$ORDER(^DGPT("AAD",DFN,IBADT,IBPTF))
IF IBPTF=""
QUIT
Begin DoDot:2
+5 SET IBN=$GET(^DGPT(IBPTF,70))
IF IBN=""!(+IBN>IBEND)
QUIT
SET IBG(-IBN,IBPTF)=IBN
End DoDot:2
End DoDot:1
+6 IF '$DATA(IBG)
GOTO ENDPTF
SET IBDXP1=10
SET IBDXP2=16
SET IBDXP3=17
SET IBCNT=0
+7 DO DX
IF '$DATA(IBD)
GOTO ENDPTF
+8 DO DX1
IF '$DATA(IBTMP)
GOTO ENDPTF
SET IBLBL="Discharge"
+9 DO DX2
ENDPTF KILL IBADT,IBCNT,IBPTF,IBST,IBEND,IBN
+1 ;
BILLDX ;print billing dx's, or at most 3 dx's from last 6 bills
+1 SET (IBST,IBEG)=(IBDT-10000)
SET IBEND=(IBDT+.99)
SET IBBN=""
+2 ;get last years billing records, store in reverse cronological order by event date
+3 FOR
SET IBBN=$ORDER(^DGCR(399,"C",DFN,IBBN))
IF IBBN=""
QUIT
Begin DoDot:1
+4 SET IBEDT=$PIECE($GET(^DGCR(399,IBBN,0)),"^",3)
IF (IBEDT>IBEND)!(IBEDT<IBEG)
QUIT
+5 SET IBN=$GET(^DGCR(399,IBBN,"C"))
IF IBN=""
QUIT
SET IBG(-IBEDT,IBBN)=IBN
End DoDot:1
+6 IF '$DATA(IBG)
GOTO ENDBILL
SET IBDXP1=14
SET IBDXP2=15
SET IBDXP3=16
SET IBCNT=0
+7 DO DX
IF '$DATA(IBD)
GOTO ENDBILL
+8 DO DX1
IF '$DATA(IBTMP)
GOTO ENDBILL
SET IBLBL="Billing"
SET IBX=""
DO ENDLN
+9 DO DX2
ENDBILL KILL IBN,IBCNT,IBST,IBEDT,IBEND,IBEG,IBX,IBBN
+1 ;
END IF IBFD
SET IBX=IBDSH
DO ENDLN
+1 KILL IBFD,IBPDN
+2 QUIT
+3 ;
DX ;get appropriate number of DX codes from choosen records
+1 SET IBDDT=""
FOR
SET IBDDT=$ORDER(IBG(IBDDT))
IF IBDDT=""!(IBPDN'>IBCNT)
QUIT
Begin DoDot:1
+2 SET IBX=""
FOR
SET IBX=$ORDER(IBG(IBDDT,IBX))
IF IBX=""!(IBPDN'>IBCNT)
QUIT
SET IBN=IBG(IBDDT,IBX)
Begin DoDot:2
+3 FOR IBI=IBDXP1,IBDXP2,IBDXP3
SET IBDX=$PIECE(IBN,"^",IBI)
IF IBDX
IF (IBPDN>IBCNT)
IF '($GET(IBR($EXTRACT(IBDDT,1,7),IBDX)))
Begin DoDot:3
+4 SET IBCNT=IBCNT+1
SET IBD(IBDDT,IBCNT)=IBDX_"^"_$SELECT(IBI=10:"*",1:" ")
IF IBCNT=IBPDN
SET IBST=-IBDDT
+5 SET IBR($EXTRACT(IBDDT,1,7),IBDX)=1
End DoDot:3
End DoDot:2
End DoDot:1
+6 KILL IBDDT,IBX,IBI,IBDX,IBN,IBR,IBG,IBDXP1,IBDXP2,IBDXP3,IBX
+7 QUIT
+8 ;
+9 ;format records found that have dx's in past year (from previous steps)
DX1 SET IBFD=1
SET IBDDT=""
SET IBROW=1
SET IBCOL=3
SET IBRMAX=(IBCNT\IBCOL)+$SELECT(IBCNT#IBCOL=0:0,1:1)
+1 ;format dx's for printing, 3 columns, descending date
+2 FOR
SET IBDDT=$ORDER(IBD(IBDDT))
IF IBDDT=""
QUIT
SET IBX=""
FOR
SET IBX=$ORDER(IBD(IBDDT,IBX))
IF IBX=""
QUIT
Begin DoDot:1
+3 SET IBDX=IBD(IBDDT,IBX)
SET IBDDTE=$$DAT1^IBOUTL(-IBDDT)
+4 SET IBDX=IBDDTE_" "_$PIECE(IBDX,"^",2)_"("_$JUSTIFY($PIECE($GET(^ICD9(+IBDX,0)),"^",1),7)_") "_$PIECE($GET(^ICD9(+IBDX,0)),"^",3)
+5 IF IBROW>IBRMAX
SET IBROW=1
SET IBCOL=IBCOL-1
SET IBRMAX=(IBCNT\IBCOL)+$SELECT(IBCNT#IBCOL=0:0,1:1)
+6 SET IBTMP(IBROW)=$SELECT($DATA(IBTMP(IBROW)):IBTMP(IBROW),1:$JUSTIFY("",IB1))_$EXTRACT(IBDX,1,IB3)_$JUSTIFY("",(IB3-$LENGTH(IBDX)))_$JUSTIFY("",IB4)
+7 SET IBROW=IBROW+1
SET IBCNT=IBCNT-1
End DoDot:1
+8 KILL IBDDT,IBROW,IBCOL,IBRMAX,IBX,IBDX,IBD,IBDDTE
+9 QUIT
+10 ;
+11 ;set results into temp array to be printed on check-off sheet
DX2 SET Y=IBST
XECUTE ^DD("DD")
SET IBEG=$PIECE(Y,"@",1)
SET Y=IBDT
XECUTE ^DD("DD")
SET IBEND=$PIECE(Y,"@",1)
+1 SET IBX=IBLBL_" Diagnosis for "_IBEG_" to "_IBEND
SET IBW=1
DO LINE
SET IBX=""
DO ENDLN
+2 SET IBDX=""
FOR
SET IBDX=$ORDER(IBTMP(IBDX))
IF IBDX=""
QUIT
SET IBX=$EXTRACT(IBTMP(IBDX),1,IOM)
DO ENDLN
+3 KILL Y,IBEG,IBEND,IBX,IBDX,IBTMP,IBLBL
+4 QUIT
+5 ;
+6 ;enters a line into the temp file used to had the COS before printing
LINE ;prints 1 (IBW=1) 2 (IBW=2) or three (IBW=3) pieces of data on a formated line
+1 ;use IBW=1 for headers centered on the page: IBX=header text
+2 ;entry at lable ENDLN can be used to insert a line with no additional formating
+3 IF IBW=1
SET IBT=IB1+(IB2-($LENGTH(IBX)/2))
SET IBX=$JUSTIFY("",IBT)_IBX
GOTO ENDLN
+4 SET IBL=$SELECT(IBW=2:IB2,1:IB3)
SET IBT=IB4
+5 SET IBX=$EXTRACT(IBX,1,IBL)
SET IBX=$JUSTIFY("",IB1)_IBX_$JUSTIFY("",(IBL-$LENGTH(IBX)))
+6 SET IBY=$EXTRACT(IBY,1,IBL)
SET IBX=IBX_$JUSTIFY("",IBT)_IBY_$JUSTIFY("",(IBL-$LENGTH(IBY)))
+7 IF IBW=3
SET IBZ=$EXTRACT(IBZ,1,IBL)
SET IBX=IBX_$JUSTIFY("",IBT)_IBZ_$JUSTIFY("",(IBL-$LENGTH(IBZ)))
ENDLN SET IBLC=IBLC+1
SET ^TMP("IBRSP",$JOB,IBLC)=IBX
+1 KILL IBT,IBL
+2 QUIT
