IBCOPV ;ALB/LDB - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
;MAP TO DGCROPV
;
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 F DGFIL=2,409.5 D CHK
K ^UTILITY($J,"CPT",0),DGCOD F I1=9999999-(IBCOPV2+1):0 S I1=$O(^DPT(DFN,"DIS",I1)) Q:'I1!(I1>(9999999-(IBCOPV1))) I $D(^(I1,0)),$P(^(0),"^",2)<2 S DGFIL=2.101,DGNOD=^(0),I=9999999-I1 D SET
D CNT,CNT399 K DIR
I 'DGCNT D NOVT^IBCOPV1 Q
D PRT^IBCOPV1 Q
CHK ;Entry point for ^IBCCPT
F I=IBCOPV1:0 S I=$S(DGFIL=2:$O(^DPT(DFN,"S",I)),1:$O(^SDV("C",DFN,I))) Q:'I!(I>(IBCOPV2+.9999)) I $S($D(^DPT(DFN,"S",I,0))&(DGFIL=2):1,DGFIL=409.5:1,1:0) D:DGFIL=2 PAT D:DGFIL=409.5 ADD D:$D(DGNOD) SET K DGNOD
Q
ADD K ^UTILITY($J,"CPT",0),DGNOD
F I1=0:0 S I1=$O(^SDV(I,"CS",I1)) Q:'I1 I $D(^(I1,0)) S DGNOD=^(0) I $D(^("PR")) S DGCPT=^("PR"),I7=$P(I,".") S:DGCPT]"" ^UTILITY($J,"CPT",0)="Y" S:'$D(^UTILITY($J,"CPT",I7)) ^(I7)="" S ^(I7)=^(I7)_"^"_DGCPT
I $O(^UTILITY($J,"CPT",0)) S ^UTILITY($J,"CPT1",I7)=^UTILITY($J,"CPT",I7) D PROD^IBCOPV2 Q
TYP Q:'$D(DGNOD) K DGNO I DGFIL'=2.101,"749"'[$P(DGNOD,"^",$S(DGFIL=2:16,1:5)) S DGNO=1 Q
S:DGFIL=409.5&($P(DGNOD,"^",4)) DGTYP=$P(DGNOD,"^",4)
K DGTYP I DGFIL=2 F Z=0:0 S Z=$O(^SC(+DGNOD,"S",I,1,Z)) Q:'Z I $D(^(Z,0)),+^(0)=DFN,$P(DGNOD,"^",16)=9 S DGTYP=$P(^(0),"^",10)
I $D(DGTYP),DGTYP,$D(^DIC(8,DGTYP,0)),"^6^7^9^12^"[("^"_$P(^(0),"^",9)_"^") S DGNO=1 Q
S:'$D(DGTYP) DGTYP=""
I DGTYP S DGTYP=$E($P($G(^DIC(8,DGTYP,0)),"^"),1,3)
S:DGTYP="" DGTYP=$P(DGNOD,"^",$S(DGFIL=2:16,DGFIL=409.5:5,1:"")) S:DGTYP&(DGTYP<9) DGTYP=$P(^SD(409.1,DGTYP,0),"^") S DGTYP=$E(DGTYP,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:"")
Q:'$D(^DGCR(399,"AOPV",DFN,DGDT))
BIL S DGBIL=0 F DGBIL1=1:1 S DGBIL=$O(^DGCR(399,"AOPV",DFN,I,DGBIL)) Q:'DGBIL I $D(^DGCR(399,DGBIL,0)) D BIL1
Q
BIL1 F B=1,7 S DGBIL(B)=$P(^DGCR(399,DGBIL,0),"^",B) I DGBIL(B)]"" S:B=7&$D(^DGCR(399.3,DGBIL(B),0)) DGBIL(B)=$P(^(0),"^",4) D BIL2
Q
BIL2 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
PAT I $P(^DPT(DFN,"S",I,0),"^",2)']"" S DGNOD=^(0)
Q
IBCOPV ;ALB/LDB - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
+3 ;MAP TO DGCROPV
+4 ;
+5 SET IBCOPV=^DGCR(399,IBIFN,"U")
SET IBCOPV1=$PIECE(IBCOPV,"^")
SET IBCOPV2=$PIECE(IBCOPV,"^",2)
IF '(IBCOPV1+IBCOPV2)
QUIT
+6 SET (DGCNT,DGU)=0
KILL DGCPT,^UTILITY($JOB),DGNOD
FOR DGFIL=2,409.5
DO CHK
+7 KILL ^UTILITY($JOB,"CPT",0),DGCOD
FOR I1=9999999-(IBCOPV2+1):0
SET I1=$ORDER(^DPT(DFN,"DIS",I1))
IF 'I1!(I1>(9999999-(IBCOPV1)))
QUIT
IF $DATA(^(I1,0))
IF $PIECE(^(0),"^",2)<2
SET DGFIL=2.101
SET DGNOD=^(0)
SET I=9999999-I1
DO SET
+8 DO CNT
DO CNT399
KILL DIR
+9 IF 'DGCNT
DO NOVT^IBCOPV1
QUIT
+10 DO PRT^IBCOPV1
QUIT
CHK ;Entry point for ^IBCCPT
+1 FOR I=IBCOPV1:0
SET I=$SELECT(DGFIL=2:$ORDER(^DPT(DFN,"S",I)),1:$ORDER(^SDV("C",DFN,I)))
IF 'I!(I>(IBCOPV2+.9999))
QUIT
IF $SELECT($DATA(^DPT(DFN,"S",I,0))&(DGFIL=2):1,DGFIL=409.5:1,1:0)
IF DGFIL=2
DO PAT
IF DGFIL=409.5
DO ADD
IF $DATA(DGNOD)
DO SET
KILL DGNOD
+2 QUIT
ADD KILL ^UTILITY($JOB,"CPT",0),DGNOD
+1 FOR I1=0:0
SET I1=$ORDER(^SDV(I,"CS",I1))
IF 'I1
QUIT
IF $DATA(^(I1,0))
SET DGNOD=^(0)
IF $DATA(^("PR"))
SET DGCPT=^("PR")
SET I7=$PIECE(I,".")
IF DGCPT]""
SET ^UTILITY($JOB,"CPT",0)="Y"
IF '$DATA(^UTILITY($JOB,"CPT",I7))
SET ^(I7)=""
SET ^(I7)=^(I7)_"^"_DGCPT
+2 IF $ORDER(^UTILITY($JOB,"CPT",0))
SET ^UTILITY($JOB,"CPT1",I7)=^UTILITY($JOB,"CPT",I7)
DO PROD^IBCOPV2
QUIT
TYP IF '$DATA(DGNOD)
QUIT
KILL DGNO
IF DGFIL'=2.101
IF "749"'[$PIECE(DGNOD,"^",$SELECT(DGFIL=2:16,1:5))
SET DGNO=1
QUIT
+1 IF DGFIL=409.5&($PIECE(DGNOD,"^",4))
SET DGTYP=$PIECE(DGNOD,"^",4)
+2 KILL DGTYP
IF DGFIL=2
FOR Z=0:0
SET Z=$ORDER(^SC(+DGNOD,"S",I,1,Z))
IF 'Z
QUIT
IF $DATA(^(Z,0))
IF +^(0)=DFN
IF $PIECE(DGNOD,"^",16)=9
SET DGTYP=$PIECE(^(0),"^",10)
+3 IF $DATA(DGTYP)
IF DGTYP
IF $DATA(^DIC(8,DGTYP,0))
IF "^6^7^9^12^"[("^"_$PIECE(^(0),"^",9)_"^")
SET DGNO=1
QUIT
+4 IF '$DATA(DGTYP)
SET DGTYP=""
+5 IF DGTYP
SET DGTYP=$EXTRACT($PIECE($GET(^DIC(8,DGTYP,0)),"^"),1,3)
+6 IF DGTYP=""
SET DGTYP=$PIECE(DGNOD,"^",$SELECT(DGFIL=2:16,DGFIL=409.5:5,1:""))
IF DGTYP&(DGTYP<9)
SET DGTYP=$PIECE(^SD(409.1,DGTYP,0),"^")
SET DGTYP=$EXTRACT(DGTYP,1,3)
+7 QUIT
SET SET DGDT=$PIECE(I,".")
SET DGDT1=$PIECE(I,".",2)
DO TYP
DO ELIG^IBCOPV2
IF $DATA(DGNO)!('$DATA(DGNOD))
QUIT
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:"")
+1 SET $PIECE(^UTILITY($JOB,"OPV",DGDT,DGDT1,DGFIL),"^",6)=$SELECT(DGCOD]"":DGCOD,1:"")
+2 IF '$DATA(^DGCR(399,"AOPV",DFN,DGDT))
QUIT
BIL SET DGBIL=0
FOR DGBIL1=1:1
SET DGBIL=$ORDER(^DGCR(399,"AOPV",DFN,I,DGBIL))
IF 'DGBIL
QUIT
IF $DATA(^DGCR(399,DGBIL,0))
DO BIL1
+1 QUIT
BIL1 FOR B=1,7
SET DGBIL(B)=$PIECE(^DGCR(399,DGBIL,0),"^",B)
IF DGBIL(B)]""
IF B=7&$DATA(^DGCR(399.3,DGBIL(B),0))
SET DGBIL(B)=$PIECE(^(0),"^",4)
DO BIL2
+1 QUIT
BIL2 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)
+1 QUIT
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
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
PAT IF $PIECE(^DPT(DFN,"S",I,0),"^",2)']""
SET DGNOD=^(0)
+1 QUIT
