- 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
