- IBOEMP1 ;ALB/ARH - EMPLOYER REPORT (SEARCH) ; 6/19/92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;
- I IBCH="OPT" G OPT
- ;
- INPT ;search for outpatient admissions (patient movement file)
- S IBB=IBBEG-.001,IBE=IBEND+.3,IBHDR=IBHDR_" FOR INPATIENT ADMISSIONS ",IBQ=0
- F S IBB=$O(^DGPM("AMV1",IBB)) Q:'IBB!(IBB>IBE)!(IBQ) D S IBQ=$$STOP^IBOEMP2
- . S IBDFN="" F S IBDFN=$O(^DGPM("AMV1",IBB,IBDFN)) Q:'IBDFN D
- .. Q:$D(^TMP("IBEMP",$J,IBDFN)) S Y=IBB D DD^%DT S IBAPDT=$P(Y,"@",1),IBPM=""
- .. F S IBPM=$O(^DGPM("AMV1",IBB,IBDFN,IBPM)) Q:IBPM="" S IBAPTYP=$P(^DGPM(IBPM,0),"^",2),IBAPTYP=$P($G(^DG(405.3,IBAPTYP,0)),"^",1)
- .. S IBAPDT=IBAPDT D PAT
- K IBB,IBE,IBDFN,IBAPDT,IBAPTYP,IBPM,X,Y
- Q
- ;
- OPT ;search for outpatient visits
- ;find ALL outpatient visits within the date range and division
- ;this includes registrations (2,1000), scheduled appointments (44,1900), and unscheduled appointments (409.5)
- ;
- DIS ;find all dispositions (2,1000) within the date range
- ; - (2,1000,1) that are not 2-APPLICATION WITHOUT EXAM
- S IBB=IBBEG-.0001,IBE=IBEND+.9,IBHDR=IBHDR_" FOR OUTPATIENT VISITS ",IBQ=0
- F S IBB=$O(^DPT("ADIS",IBB)) Q:'IBB!(IBB>IBE)!(IBQ) S IBDFN=0 D S IBQ=$$STOP^IBOEMP2
- . F S IBDFN=$O(^DPT("ADIS",IBB,IBDFN)) Q:'IBDFN S IBY=0 I '$D(^TMP("IBEMP",$J,IBDFN)) D
- .. F S IBY=$O(^DPT("ADIS",IBB,IBDFN,IBY)) Q:'IBY S IBX=$G(^DPT(IBDFN,"DIS",IBY,0)) I +IBX,$P(IBX,U,2)<2,(VAUTD=1!($D(VAUTD(+$P(IBX,"^",4))))) D
- ... S IBAPTYP="DISPOSITION",IBAPDT=IBB\1
- ... D PAT
- ;
- ;
- APPT ;outpatient: find all scheduled appointments (44,1900 -> 2,1900)
- ; - must be clinic appointments (44,2.1 -> "AC" x-ref)
- ; - (2,1900,3) that are outpatient, have not been canceled or no-showed etc.
- S IBE=IBEND+.3,IBCLN=0
- F S IBCLN=$O(^SC("AC","C",IBCLN)) Q:'IBCLN!(IBQ) D S IBQ=$$STOP^IBOEMP2
- . I VAUTD'=1,'$D(VAUTD(+$P($G(^SC(IBCLN,0)),"^",15))) Q ; check division
- . S IBB=IBBEG-.0001 F S IBB=$O(^SC(IBCLN,"S",IBB)) Q:'IBB!(IBB>IBE) D
- .. S IBY=0 F S IBY=$O(^SC(IBCLN,"S",IBB,1,IBY)) Q:'IBY S IBX=$G(^SC(IBCLN,"S",IBB,1,IBY,0)) I +IBX D
- ... S IBDFN=+IBX I $D(^TMP("IBEMP",$J,IBDFN)) Q
- ... S IBXP=$G(^DPT(IBDFN,"S",IBB,0)) I +IBXP'=IBCLN,$P(IBXP,U,2)'="" Q
- ... S IBAPTYP=$P($G(^SD(409.1,+$P(IBXP,U,16),0)),U,1),IBAPDT=IBB\1
- ... D PAT
- ;
- ;
- STOP ;outpatient: find all unscheduled outpatient appointments (409.5, add/edit) for the patient
- S IBB=IBBEG-.001,IBE=IBEND+.3
- F S IBB=$O(^SDV(IBB)) Q:'IBB!(IBB>IBE)!(IBQ) D S IBQ=$$STOP^IBOEMP2
- . S IBX=$G(^SDV(IBB,0)) I IBX'="",(VAUTD=1!($D(VAUTD(+$P(IBX,"^",3))))) S IBDFN=+$P(IBX,"^",2) D
- .. Q:$D(^TMP("IBEMP",$J,IBDFN)) S Y=IBB D DD^%DT S IBAPDT=$P(Y,"@",1)
- .. S IBAPTYP=$O(^SDV(IBB,"CS",0)),IBAPTYP=$P($G(^SDV(IBB,"CS",+IBAPTYP,0)),"^",5),IBAPTYP=$P($G(^SD(409.1,+IBAPTYP,0)),"^",1)
- .. D PAT
- K IBB,IBE,IBX,IBY,IBCLN,IBXP,IBDFN,IBAPDT,IBAPTYP,X,Y
- Q
- ;
- ;Input: IBB,IBDFN,IBAPTYP,IBAPDT
- PAT ;gather data on patients with no insurance at time of care
- N IBX,IBY
- I $D(^TMP("IBEMP",$J,IBDFN)) G PEND ; quit if this patient has already been processed
- S ^TMP("IBEMP",$J,IBDFN)="" ; once a pt is checked don't check again
- S DFN=IBDFN,IBINDT=IBB D ^IBCNS G:IBINS PEND ; quit if patient has insurance
- D DEM^VADPT G:+VADM(6) PEND ; quit if patient is dead
- D ELIG^VADPT S IBPELG=$G(^DIC(8,+VAEL(1),0)),IBPELG=$S($P(IBPELG,"^",3)'="":$P(IBPELG,"^",3),1:$E($P(VAEL(1),"^",2),1,4)) K VAEL
- D OPD^VADPT S IBSES=$P($G(^DPT(DFN,.25)),"^",15) ; spouses employment status
- ;
- ;get patient and spouse's employer data
- ;add to report if patient or spouse employment status is employed or the patients or spouse employer name is defined
- S DFN=IBDFN F Z=5,6 S VAOA("A")=Z D OAD^VADPT I VAOA(9)'=""!(Z=5&("1245"[+VAPD(7)))!(Z=6&("1245"[+IBSES)) D K VAOA
- . S IBZ=$S(VAOA("A")=5:"P",1:"S"),IBADD="",IBADDN=VAOA(9),VAOA(5)=$P(VAOA(5),"^",2),IBX=0
- . S IBY=$A(IBADDN) I IBY>96,IBY<123 S IBY=IBY-82 ; deal with lower case
- . I IBY<IBRGB!(IBY>IBRGE) Q ; is employer name within range?
- . I IBADDN="" S (VAOA(9),IBADDN)="{EMPLOYER NOT SPECIFIED}"
- . F IBI=9,1:1:6,8 S IBX=IBX+1 I VAOA(IBI)'="" S $P(IBADD,"^",IBX)=VAOA(IBI)
- . S IBY="",IBX=1
- . I $D(^TMP("IBEMP",$J,"E",IBADDN)) F S IBY=$O(^TMP("IBEMP",$J,"E",IBADDN,IBY)) Q:IBY="" Q:^TMP("IBEMP",$J,"E",IBADDN,IBY)=IBADD S IBX=IBX+1
- . S ^TMP("IBEMP",$J,"E",IBADDN)=+$G(^TMP("IBEMP",$J,"E",IBADDN))+1
- . S ^TMP("IBEMP",$J,"E",IBADDN,IBX)=IBADD
- . S ^TMP("IBEMP",$J,"E",IBADDN,IBX,VADM(1),IBDFN,IBZ)=""
- . S ^TMP("IBEMP",$J,IBDFN)=VADM(1)_"^"_$P(VADM(2),U,2)_"^"_IBAPDT_"^"_IBAPTYP_"^"_IBPELG
- . I IBZ="P" D OPD^VADPT S ^TMP("IBEMP",$J,IBDFN,IBZ)=VADM(1)_"^"_VAPD(6)_"^"_$P(IBES,"^",+VAPD(7))_"^"_$P(VADM(2),"^",2) Q
- . D GETREL^DGMTU11(DFN,IBZ,IBEND) S IBY=$G(DGREL("S"))
- . S ^TMP("IBEMP",$J,IBDFN,IBZ)=$$NAME^DGMTU1(+IBY)_"^"_$P($G(^DPT(DFN,.25)),"^",14)_"^"_$P(IBES,"^",+IBSES)_"^"_$$SSN^DGMTU1(+IBY)
- PEND K VAIP,VADM,VAEL,VAPD,VAOA,DGREL,IBINDT,IBINS,DFN,IBPELG,IBSES,IBPAT,IBADD,IBADDN,IBI,IBX,IBY,IBZ,Z
- Q
- IBOEMP1 ;ALB/ARH - EMPLOYER REPORT (SEARCH) ; 6/19/92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;
- +3 IF IBCH="OPT"
- GOTO OPT
- +4 ;
- INPT ;search for outpatient admissions (patient movement file)
- +1 SET IBB=IBBEG-.001
- SET IBE=IBEND+.3
- SET IBHDR=IBHDR_" FOR INPATIENT ADMISSIONS "
- SET IBQ=0
- +2 FOR
- SET IBB=$ORDER(^DGPM("AMV1",IBB))
- IF 'IBB!(IBB>IBE)!(IBQ)
- QUIT
- Begin DoDot:1
- +3 SET IBDFN=""
- FOR
- SET IBDFN=$ORDER(^DGPM("AMV1",IBB,IBDFN))
- IF 'IBDFN
- QUIT
- Begin DoDot:2
- +4 IF $DATA(^TMP("IBEMP",$JOB,IBDFN))
- QUIT
- SET Y=IBB
- DO DD^%DT
- SET IBAPDT=$PIECE(Y,"@",1)
- SET IBPM=""
- +5 FOR
- SET IBPM=$ORDER(^DGPM("AMV1",IBB,IBDFN,IBPM))
- IF IBPM=""
- QUIT
- SET IBAPTYP=$PIECE(^DGPM(IBPM,0),"^",2)
- SET IBAPTYP=$PIECE($GET(^DG(405.3,IBAPTYP,0)),"^",1)
- +6 SET IBAPDT=IBAPDT
- DO PAT
- End DoDot:2
- End DoDot:1
- SET IBQ=$$STOP^IBOEMP2
- +7 KILL IBB,IBE,IBDFN,IBAPDT,IBAPTYP,IBPM,X,Y
- +8 QUIT
- +9 ;
- OPT ;search for outpatient visits
- +1 ;find ALL outpatient visits within the date range and division
- +2 ;this includes registrations (2,1000), scheduled appointments (44,1900), and unscheduled appointments (409.5)
- +3 ;
- DIS ;find all dispositions (2,1000) within the date range
- +1 ; - (2,1000,1) that are not 2-APPLICATION WITHOUT EXAM
- +2 SET IBB=IBBEG-.0001
- SET IBE=IBEND+.9
- SET IBHDR=IBHDR_" FOR OUTPATIENT VISITS "
- SET IBQ=0
- +3 FOR
- SET IBB=$ORDER(^DPT("ADIS",IBB))
- IF 'IBB!(IBB>IBE)!(IBQ)
- QUIT
- SET IBDFN=0
- Begin DoDot:1
- +4 FOR
- SET IBDFN=$ORDER(^DPT("ADIS",IBB,IBDFN))
- IF 'IBDFN
- QUIT
- SET IBY=0
- IF '$DATA(^TMP("IBEMP",$JOB,IBDFN))
- Begin DoDot:2
- +5 FOR
- SET IBY=$ORDER(^DPT("ADIS",IBB,IBDFN,IBY))
- IF 'IBY
- QUIT
- SET IBX=$GET(^DPT(IBDFN,"DIS",IBY,0))
- IF +IBX
- IF $PIECE(IBX,U,2)<2
- IF (VAUTD=1!($DATA(VAUTD(+$PIECE(IBX,"^",4)))))
- Begin DoDot:3
- +6 SET IBAPTYP="DISPOSITION"
- SET IBAPDT=IBB\1
- +7 DO PAT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- SET IBQ=$$STOP^IBOEMP2
- +8 ;
- +9 ;
- APPT ;outpatient: find all scheduled appointments (44,1900 -> 2,1900)
- +1 ; - must be clinic appointments (44,2.1 -> "AC" x-ref)
- +2 ; - (2,1900,3) that are outpatient, have not been canceled or no-showed etc.
- +3 SET IBE=IBEND+.3
- SET IBCLN=0
- +4 FOR
- SET IBCLN=$ORDER(^SC("AC","C",IBCLN))
- IF 'IBCLN!(IBQ)
- QUIT
- Begin DoDot:1
- +5 ; check division
- IF VAUTD'=1
- IF '$DATA(VAUTD(+$PIECE($GET(^SC(IBCLN,0)),"^",15)))
- QUIT
- +6 SET IBB=IBBEG-.0001
- FOR
- SET IBB=$ORDER(^SC(IBCLN,"S",IBB))
- IF 'IBB!(IBB>IBE)
- QUIT
- Begin DoDot:2
- +7 SET IBY=0
- FOR
- SET IBY=$ORDER(^SC(IBCLN,"S",IBB,1,IBY))
- IF 'IBY
- QUIT
- SET IBX=$GET(^SC(IBCLN,"S",IBB,1,IBY,0))
- IF +IBX
- Begin DoDot:3
- +8 SET IBDFN=+IBX
- IF $DATA(^TMP("IBEMP",$JOB,IBDFN))
- QUIT
- +9 SET IBXP=$GET(^DPT(IBDFN,"S",IBB,0))
- IF +IBXP'=IBCLN
- IF $PIECE(IBXP,U,2)'=""
- QUIT
- +10 SET IBAPTYP=$PIECE($GET(^SD(409.1,+$PIECE(IBXP,U,16),0)),U,1)
- SET IBAPDT=IBB\1
- +11 DO PAT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- SET IBQ=$$STOP^IBOEMP2
- +12 ;
- +13 ;
- STOP ;outpatient: find all unscheduled outpatient appointments (409.5, add/edit) for the patient
- +1 SET IBB=IBBEG-.001
- SET IBE=IBEND+.3
- +2 FOR
- SET IBB=$ORDER(^SDV(IBB))
- IF 'IBB!(IBB>IBE)!(IBQ)
- QUIT
- Begin DoDot:1
- +3 SET IBX=$GET(^SDV(IBB,0))
- IF IBX'=""
- IF (VAUTD=1!($DATA(VAUTD(+$PIECE(IBX,"^",3)))))
- SET IBDFN=+$PIECE(IBX,"^",2)
- Begin DoDot:2
- +4 IF $DATA(^TMP("IBEMP",$JOB,IBDFN))
- QUIT
- SET Y=IBB
- DO DD^%DT
- SET IBAPDT=$PIECE(Y,"@",1)
- +5 SET IBAPTYP=$ORDER(^SDV(IBB,"CS",0))
- SET IBAPTYP=$PIECE($GET(^SDV(IBB,"CS",+IBAPTYP,0)),"^",5)
- SET IBAPTYP=$PIECE($GET(^SD(409.1,+IBAPTYP,0)),"^",1)
- +6 DO PAT
- End DoDot:2
- End DoDot:1
- SET IBQ=$$STOP^IBOEMP2
- +7 KILL IBB,IBE,IBX,IBY,IBCLN,IBXP,IBDFN,IBAPDT,IBAPTYP,X,Y
- +8 QUIT
- +9 ;
- +10 ;Input: IBB,IBDFN,IBAPTYP,IBAPDT
- PAT ;gather data on patients with no insurance at time of care
- +1 NEW IBX,IBY
- +2 ; quit if this patient has already been processed
- IF $DATA(^TMP("IBEMP",$JOB,IBDFN))
- GOTO PEND
- +3 ; once a pt is checked don't check again
- SET ^TMP("IBEMP",$JOB,IBDFN)=""
- +4 ; quit if patient has insurance
- SET DFN=IBDFN
- SET IBINDT=IBB
- DO ^IBCNS
- IF IBINS
- GOTO PEND
- +5 ; quit if patient is dead
- DO DEM^VADPT
- IF +VADM(6)
- GOTO PEND
- +6 DO ELIG^VADPT
- SET IBPELG=$GET(^DIC(8,+VAEL(1),0))
- SET IBPELG=$SELECT($PIECE(IBPELG,"^",3)'="":$PIECE(IBPELG,"^",3),1:$EXTRACT($PIECE(VAEL(1),"^",2),1,4))
- KILL VAEL
- +7 ; spouses employment status
- DO OPD^VADPT
- SET IBSES=$PIECE($GET(^DPT(DFN,.25)),"^",15)
- +8 ;
- +9 ;get patient and spouse's employer data
- +10 ;add to report if patient or spouse employment status is employed or the patients or spouse employer name is defined
- +11 SET DFN=IBDFN
- FOR Z=5,6
- SET VAOA("A")=Z
- DO OAD^VADPT
- IF VAOA(9)'=""!(Z=5&("1245"[+VAPD(7)))!(Z=6&("1245"[+IBSES))
- Begin DoDot:1
- +12 SET IBZ=$SELECT(VAOA("A")=5:"P",1:"S")
- SET IBADD=""
- SET IBADDN=VAOA(9)
- SET VAOA(5)=$PIECE(VAOA(5),"^",2)
- SET IBX=0
- +13 ; deal with lower case
- SET IBY=$ASCII(IBADDN)
- IF IBY>96
- IF IBY<123
- SET IBY=IBY-82
- +14 ; is employer name within range?
- IF IBY<IBRGB!(IBY>IBRGE)
- QUIT
- +15 IF IBADDN=""
- SET (VAOA(9),IBADDN)="{EMPLOYER NOT SPECIFIED}"
- +16 FOR IBI=9,1:1:6,8
- SET IBX=IBX+1
- IF VAOA(IBI)'=""
- SET $PIECE(IBADD,"^",IBX)=VAOA(IBI)
- +17 SET IBY=""
- SET IBX=1
- +18 IF $DATA(^TMP("IBEMP",$JOB,"E",IBADDN))
- FOR
- SET IBY=$ORDER(^TMP("IBEMP",$JOB,"E",IBADDN,IBY))
- IF IBY=""
- QUIT
- IF ^TMP("IBEMP",$JOB,"E",IBADDN,IBY)=IBADD
- QUIT
- SET IBX=IBX+1
- +19 SET ^TMP("IBEMP",$JOB,"E",IBADDN)=+$GET(^TMP("IBEMP",$JOB,"E",IBADDN))+1
- +20 SET ^TMP("IBEMP",$JOB,"E",IBADDN,IBX)=IBADD
- +21 SET ^TMP("IBEMP",$JOB,"E",IBADDN,IBX,VADM(1),IBDFN,IBZ)=""
- +22 SET ^TMP("IBEMP",$JOB,IBDFN)=VADM(1)_"^"_$PIECE(VADM(2),U,2)_"^"_IBAPDT_"^"_IBAPTYP_"^"_IBPELG
- +23 IF IBZ="P"
- DO OPD^VADPT
- SET ^TMP("IBEMP",$JOB,IBDFN,IBZ)=VADM(1)_"^"_VAPD(6)_"^"_$PIECE(IBES,"^",+VAPD(7))_"^"_$PIECE(VADM(2),"^",2)
- QUIT
- +24 DO GETREL^DGMTU11(DFN,IBZ,IBEND)
- SET IBY=$GET(DGREL("S"))
- +25 SET ^TMP("IBEMP",$JOB,IBDFN,IBZ)=$$NAME^DGMTU1(+IBY)_"^"_$PIECE($GET(^DPT(DFN,.25)),"^",14)_"^"_$PIECE(IBES,"^",+IBSES)_"^"_$$SSN^DGMTU1(+IBY)
- End DoDot:1
- KILL VAOA
- PEND KILL VAIP,VADM,VAEL,VAPD,VAOA,DGREL,IBINDT,IBINS,DFN,IBPELG,IBSES,IBPAT,IBADD,IBADDN,IBI,IBX,IBY,IBZ,Z
- +1 QUIT
