IBCOPV ;ALB/LDB,TMP - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
;;2.0;INTEGRATED BILLING;**27,91,106,124,174,260**;21-MAR-94
;
;MAP TO DGCROPV ... input IBIFN
;
N DGNO,DGNO1,IBCBK,IBVAL,IBZ,IBPB,IBOE,IBOE0
S IBCOPV=^DGCR(399,IBIFN,"U"),IBCOPV1=$P(IBCOPV,"^"),IBCOPV2=$P(IBCOPV,"^",2) Q:'(IBCOPV1+IBCOPV2)
S (DGCNT,DGU)=0 K DGCPT,^UTILITY($J),DGNOD
;
S IBVAL("DFN")=DFN,IBVAL("BDT")=IBCOPV1,IBVAL("EDT")=IBCOPV2+.9999
S IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,+$P(Y0,U,8),Y)=Y0"
K ^TMP("IBOE",$J)
S DGNO1=1
D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1) K ^TMP("DIERR",$J)
F IBZ=9,13 S IBCK(IBZ)=""
K ^TMP("IBVIS",$J)
S IBZ=0 F S IBZ=$O(^TMP("IBOE",$J,IBZ)) Q:'IBZ S IBOE=0 F S IBOE=$O(^TMP("IBOE",$J,IBZ,IBOE)) Q:'IBOE S IBOE0=$G(^(IBOE)) D
. K IBPB
. S IBEP=$$BILLCK^IBAMTEDU(IBOE,IBOE0,.IBCK,.IBPB)
. I IBEP D CHK(IBOE,IBOE0,.DGNO1)
. S ^TMP("IBVIS",$J,+$P(IBOE0,U,5))=""
K ^TMP("IBOE",$J),^TMP("IBVIS",$J)
D CNT,CNT399 K DIR
I 'DGCNT D NOVT^IBCOPV1 Q
D PRT^IBCOPV1
Q
;
CHK(IBOE,IBOE0,DGNO1) ;
N IBZ,DGFIL,DFN,I,DGNOD
S DGFIL=$P("2^409.5^2.101^",U,+$P(IBOE0,U,8)),DFN=$P(IBOE0,U,2),I=+IBOE0
;
Q:'DGFIL
I '$$BDSRC^IBEFUNC3($P(IBOE0,U,5)) Q ; non-billable visit data source
;
I '$D(^TMP("IBVIS",$J,+$P(IBOE0,U,5))) D ;Process visit CPT's only once
.N I,I2,I7,IBCPT,IBCPTS,IBZERR
.D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
.Q:'$O(IBCPTS(0)) ;No procedures for this encounter
.S I7=IBOE0\1
.S I2=0 F S I2=$O(IBCPTS(I2)) Q:'I2 D
.. N Z
.. S IBCPT=$P(IBCPTS(I2),U)
.. F Z=1:1:$P(IBCPTS(I2),U,16) D
... I $L($G(^UTILITY($J,"CPT",I7,DGNO1)))+$L(IBCPT)+1>140 S DGNO1=DGNO1+1
... S ^UTILITY($J,"CPT",I7,DGNO1)=$G(^UTILITY($J,"CPT",I7,DGNO1))_U_IBCPT
.S ^UTILITY($J,"CPT",0)="Y"
.;
.I $O(^UTILITY($J,"CPT",0)) S DGNO=0 F S DGNO=$O(^UTILITY($J,"CPT",I7,DGNO)) Q:DGNO="" S ^UTILITY($J,"CPT1",I7,DGNO)=^UTILITY($J,"CPT",I7,DGNO) D PROD^IBCOPV2
;
N IBPRVS,IBPRV,IBI S IBPRV="" D GETPRV^SDOE(IBOE,"IBPRVS")
S IBI=0 F S IBI=$O(IBPRVS(IBI)) Q:'IBI I $P(IBPRVS(IBI),U,4)="P" S IBPRV=+IBPRVS(IBI) Q
;
S DGNOD=IBOE0
D SET K DGNOD
Q
;
TYP ;Q:'$D(DGNOD)
;K DGNO,DGTYP
;I "479"'[$P(DGNOD,U,10) S DGNO=1 Q
;I DGFIL=2,$P(DGNOD,U,10)=9 D Q:$G(DGNO)
;. I $P(DGNOD,U,10)=9 S DGTYP=$P(DGNOD,U,13)
;. I $G(DGTYP),"^6^7^9^"[(U_$P($G(^DIC(8,DGTYP,0)),U,9)_U) S DGNO=1
;I $G(DGTYP) S DGTYP=$E($P($G(^DIC(8,DGTYP,0)),"^"),1,3)
;S:$G(DGTYP)="" DGTYP=$P(DGNOD,U,10)
;S:DGTYP&(DGTYP<9) DGTYP=$E($P($G(^SD(409.1,+DGTYP,0)),U),1,3)
;S DGTYP=$E(DGTYP,1,3)
;;- If the code gets here, DGTYP will either be the first 3 charaters of the
;; appointment type name, the first 3 characters of the eligibility name or a 9
;
; appointment type must be: 4 - Employee, 7 - Collateral of Vet, 8 - Sharing Agreement, or 9 - Regular
; appointment MAS eligibilty must not be: 6 - Other Federal Agency, or 7 - Allied Veteran
;
; if 9-regular or 8-sharing agreement then return appointment eligibilty, otherwise return appointment type
;
Q:'$D(DGNOD) K DGNO,DGTYP N IBZT,IBZE,IBZ
S DGTYP=""
S IBZT=$P(DGNOD,U,10) I "4789"'[IBZT S DGNO=1 Q
S IBZE=$P(DGNOD,U,13),IBZ=+$P($G(^DIC(8,+IBZE,0)),U,9) I +IBZ,"6^7"[IBZ S DGNO=1 Q
;
I +IBZT,IBZT<8 S DGTYP=$E($P($G(^SD(409.1,+IBZT,0)),U,1),1,3)
I +IBZE,DGTYP="" S DGTYP=$E($P($G(^DIC(8,+IBZE,0)),U,1),1,3)
Q
;
SET S DGDT=$P(I,"."),DGDT1=$P(I,".",2)
D TYP,ELIG^IBCOPV2 Q:$D(DGNO)!('$D(DGNOD))
S:'$D(DGNO) ^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL)=DGTYP_"^"_DGMT_"^"_$S($D(^UTILITY($J,"CPT",0))&(DGFIL=409.5):^UTILITY($J,"CPT",0),1:"")
S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",6)=$S(DGCOD]"":DGCOD,1:"")
S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",7)=$G(IBCODCL)
S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",8)=$G(IBPRV)
S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",9)=$G(IBOE)
Q:'$D(^DGCR(399,"AOPV",DFN,DGDT))
BIL S DGBIL=0 N IBZ
F DGBIL1=1:1 S DGBIL=$O(^DGCR(399,"AOPV",DFN,I,DGBIL)) Q:'DGBIL I $D(^DGCR(399,DGBIL,0)) D
. F B=1,7 S DGBIL(B)=$P(^DGCR(399,DGBIL,0),"^",B) I DGBIL(B)]"" D
.. I B=7 S IBZ=$P(^DGCR(399,DGBIL,0),"^",27),IBZ=$S(+IBZ=1:"-I",+IBZ=2:"-P",1:"")
.. I B=7,$D(^DGCR(399.3,DGBIL(B),0)) S DGBIL(B)=$P(^(0),"^",4) I IBZ'="" S DGBIL(B)=$E(DGBIL(B),1,6)_IBZ
.. S $P(^UTILITY($J,"OPV","AP",DGCNT),"^",$S((DGBIL1+B)=2:4,(DGBIL1+B)=8:5,(DGBIL1+B)<8:(DGBIL1+DGBIL1+2),1:(DGBIL1+DGBIL1+3)))=DGBIL(B)
Q
;
CNT F I=0:0 S I=$O(^UTILITY($J,"OPV",I)) Q:'I S DGCNT=DGCNT+1,^UTILITY($J,"OPV","AP",DGCNT)=I D CHG^IBCOPV2,BIL
Q
;
CNT399 S DGCNT1=0 F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I S DGCNT1=DGCNT1+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOPV 4619 printed Jan 18, 2025@03:19:49 Page 2
IBCOPV ;ALB/LDB,TMP - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
+1 ;;2.0;INTEGRATED BILLING;**27,91,106,124,174,260**;21-MAR-94
+2 ;
+3 ;MAP TO DGCROPV ... input IBIFN
+4 ;
+5 NEW DGNO,DGNO1,IBCBK,IBVAL,IBZ,IBPB,IBOE,IBOE0
+6 SET IBCOPV=^DGCR(399,IBIFN,"U")
SET IBCOPV1=$PIECE(IBCOPV,"^")
SET IBCOPV2=$PIECE(IBCOPV,"^",2)
if '(IBCOPV1+IBCOPV2)
QUIT
+7 SET (DGCNT,DGU)=0
KILL DGCPT,^UTILITY($JOB),DGNOD
+8 ;
+9 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=IBCOPV1
SET IBVAL("EDT")=IBCOPV2+.9999
+10 SET IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,+$P(Y0,U,8),Y)=Y0"
+11 KILL ^TMP("IBOE",$JOB)
+12 SET DGNO1=1
+13 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
KILL ^TMP("DIERR",$JOB)
+14 FOR IBZ=9,13
SET IBCK(IBZ)=""
+15 KILL ^TMP("IBVIS",$JOB)
+16 SET IBZ=0
FOR
SET IBZ=$ORDER(^TMP("IBOE",$JOB,IBZ))
if 'IBZ
QUIT
SET IBOE=0
FOR
SET IBOE=$ORDER(^TMP("IBOE",$JOB,IBZ,IBOE))
if 'IBOE
QUIT
SET IBOE0=$GET(^(IBOE))
Begin DoDot:1
+17 KILL IBPB
+18 SET IBEP=$$BILLCK^IBAMTEDU(IBOE,IBOE0,.IBCK,.IBPB)
+19 IF IBEP
DO CHK(IBOE,IBOE0,.DGNO1)
+20 SET ^TMP("IBVIS",$JOB,+$PIECE(IBOE0,U,5))=""
End DoDot:1
+21 KILL ^TMP("IBOE",$JOB),^TMP("IBVIS",$JOB)
+22 DO CNT
DO CNT399
KILL DIR
+23 IF 'DGCNT
DO NOVT^IBCOPV1
QUIT
+24 DO PRT^IBCOPV1
+25 QUIT
+26 ;
CHK(IBOE,IBOE0,DGNO1) ;
+1 NEW IBZ,DGFIL,DFN,I,DGNOD
+2 SET DGFIL=$PIECE("2^409.5^2.101^",U,+$PIECE(IBOE0,U,8))
SET DFN=$PIECE(IBOE0,U,2)
SET I=+IBOE0
+3 ;
+4 if 'DGFIL
QUIT
+5 ; non-billable visit data source
IF '$$BDSRC^IBEFUNC3($PIECE(IBOE0,U,5))
QUIT
+6 ;
+7 ;Process visit CPT's only once
IF '$DATA(^TMP("IBVIS",$JOB,+$PIECE(IBOE0,U,5)))
Begin DoDot:1
+8 NEW I,I2,I7,IBCPT,IBCPTS,IBZERR
+9 DO GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
+10 ;No procedures for this encounter
if '$ORDER(IBCPTS(0))
QUIT
+11 SET I7=IBOE0\1
+12 SET I2=0
FOR
SET I2=$ORDER(IBCPTS(I2))
if 'I2
QUIT
Begin DoDot:2
+13 NEW Z
+14 SET IBCPT=$PIECE(IBCPTS(I2),U)
+15 FOR Z=1:1:$PIECE(IBCPTS(I2),U,16)
Begin DoDot:3
+16 IF $LENGTH($GET(^UTILITY($JOB,"CPT",I7,DGNO1)))+$LENGTH(IBCPT)+1>140
SET DGNO1=DGNO1+1
+17 SET ^UTILITY($JOB,"CPT",I7,DGNO1)=$GET(^UTILITY($JOB,"CPT",I7,DGNO1))_U_IBCPT
End DoDot:3
End DoDot:2
+18 SET ^UTILITY($JOB,"CPT",0)="Y"
+19 ;
+20 IF $ORDER(^UTILITY($JOB,"CPT",0))
SET DGNO=0
FOR
SET DGNO=$ORDER(^UTILITY($JOB,"CPT",I7,DGNO))
if DGNO=""
QUIT
SET ^UTILITY($JOB,"CPT1",I7,DGNO)=^UTILITY($JOB,"CPT",I7,DGNO)
DO PROD^IBCOPV2
End DoDot:1
+21 ;
+22 NEW IBPRVS,IBPRV,IBI
SET IBPRV=""
DO GETPRV^SDOE(IBOE,"IBPRVS")
+23 SET IBI=0
FOR
SET IBI=$ORDER(IBPRVS(IBI))
if 'IBI
QUIT
IF $PIECE(IBPRVS(IBI),U,4)="P"
SET IBPRV=+IBPRVS(IBI)
QUIT
+24 ;
+25 SET DGNOD=IBOE0
+26 DO SET
KILL DGNOD
+27 QUIT
+28 ;
TYP ;Q:'$D(DGNOD)
+1 ;K DGNO,DGTYP
+2 ;I "479"'[$P(DGNOD,U,10) S DGNO=1 Q
+3 ;I DGFIL=2,$P(DGNOD,U,10)=9 D Q:$G(DGNO)
+4 ;. I $P(DGNOD,U,10)=9 S DGTYP=$P(DGNOD,U,13)
+5 ;. I $G(DGTYP),"^6^7^9^"[(U_$P($G(^DIC(8,DGTYP,0)),U,9)_U) S DGNO=1
+6 ;I $G(DGTYP) S DGTYP=$E($P($G(^DIC(8,DGTYP,0)),"^"),1,3)
+7 ;S:$G(DGTYP)="" DGTYP=$P(DGNOD,U,10)
+8 ;S:DGTYP&(DGTYP<9) DGTYP=$E($P($G(^SD(409.1,+DGTYP,0)),U),1,3)
+9 ;S DGTYP=$E(DGTYP,1,3)
+10 ;;- If the code gets here, DGTYP will either be the first 3 charaters of the
+11 ;; appointment type name, the first 3 characters of the eligibility name or a 9
+12 ;
+13 ; appointment type must be: 4 - Employee, 7 - Collateral of Vet, 8 - Sharing Agreement, or 9 - Regular
+14 ; appointment MAS eligibilty must not be: 6 - Other Federal Agency, or 7 - Allied Veteran
+15 ;
+16 ; if 9-regular or 8-sharing agreement then return appointment eligibilty, otherwise return appointment type
+17 ;
+18 if '$DATA(DGNOD)
QUIT
KILL DGNO,DGTYP
NEW IBZT,IBZE,IBZ
+19 SET DGTYP=""
+20 SET IBZT=$PIECE(DGNOD,U,10)
IF "4789"'[IBZT
SET DGNO=1
QUIT
+21 SET IBZE=$PIECE(DGNOD,U,13)
SET IBZ=+$PIECE($GET(^DIC(8,+IBZE,0)),U,9)
IF +IBZ
IF "6^7"[IBZ
SET DGNO=1
QUIT
+22 ;
+23 IF +IBZT
IF IBZT<8
SET DGTYP=$EXTRACT($PIECE($GET(^SD(409.1,+IBZT,0)),U,1),1,3)
+24 IF +IBZE
IF DGTYP=""
SET DGTYP=$EXTRACT($PIECE($GET(^DIC(8,+IBZE,0)),U,1),1,3)
+25 QUIT
+26 ;
SET SET DGDT=$PIECE(I,".")
SET DGDT1=$PIECE(I,".",2)
+1 DO TYP
DO ELIG^IBCOPV2
if $DATA(DGNO)!('$DATA(DGNOD))
QUIT
+2 if '$DATA(DGNO)
SET ^UTILITY($JOB,"OPV",DGDT,DGDT1,DGFIL)=DGTYP_"^"_DGMT_"^"_$SELECT($DATA(^UTILITY($JOB,"CPT",0))&(DGFIL=409.5):^UTILITY($JOB,"CPT",0),1:"")
+3 SET $PIECE(^UTILITY($JOB,"OPV",DGDT,DGDT1,DGFIL),"^",6)=$SELECT(DGCOD]"":DGCOD,1:"")
+4 SET $PIECE(^UTILITY($JOB,"OPV",DGDT,DGDT1,DGFIL),"^",7)=$GET(IBCODCL)
+5 SET $PIECE(^UTILITY($JOB,"OPV",DGDT,DGDT1,DGFIL),"^",8)=$GET(IBPRV)
+6 SET $PIECE(^UTILITY($JOB,"OPV",DGDT,DGDT1,DGFIL),"^",9)=$GET(IBOE)
+7 if '$DATA(^DGCR(399,"AOPV",DFN,DGDT))
QUIT
BIL SET DGBIL=0
NEW IBZ
+1 FOR DGBIL1=1:1
SET DGBIL=$ORDER(^DGCR(399,"AOPV",DFN,I,DGBIL))
if 'DGBIL
QUIT
IF $DATA(^DGCR(399,DGBIL,0))
Begin DoDot:1
+2 FOR B=1,7
SET DGBIL(B)=$PIECE(^DGCR(399,DGBIL,0),"^",B)
IF DGBIL(B)]""
Begin DoDot:2
+3 IF B=7
SET IBZ=$PIECE(^DGCR(399,DGBIL,0),"^",27)
SET IBZ=$SELECT(+IBZ=1:"-I",+IBZ=2:"-P",1:"")
+4 IF B=7
IF $DATA(^DGCR(399.3,DGBIL(B),0))
SET DGBIL(B)=$PIECE(^(0),"^",4)
IF IBZ'=""
SET DGBIL(B)=$EXTRACT(DGBIL(B),1,6)_IBZ
+5 SET $PIECE(^UTILITY($JOB,"OPV","AP",DGCNT),"^",$SELECT((DGBIL1+B)=2:4,(DGBIL1+B)=8:5,(DGBIL1+B)<8:(DGBIL1+DGBIL1+2),1:(DGBIL1+DGBIL1+3)))=DGBIL(B)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
CNT FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"OPV",I))
if 'I
QUIT
SET DGCNT=DGCNT+1
SET ^UTILITY($JOB,"OPV","AP",DGCNT)=I
DO CHG^IBCOPV2
DO BIL
+1 QUIT
+2 ;
CNT399 SET DGCNT1=0
FOR I=0:0
SET I=$ORDER(^DGCR(399,IBIFN,"OP",I))
if 'I
QUIT
SET DGCNT1=DGCNT1+1
+1 QUIT
+2 ;
