Routine: IBTODD

IBTODD ;ALB/AAS - CLAIMS TRACKING DENIED DAYS REPORT ; 27-OCT-93

 ;;2.0;INTEGRATED BILLING;**32,458,730**;21-MAR-94;Build 83

% I '$D(DT) D DT^DICRW

 W !!,"Denied Days Report",!!

 S IBSORT="P",IBSELECT="1,2,3,4,"

 N DIR

 S DIR("?")="Answer YES if you only want to print a summary or answer NO if you want a detailed listing plus the summary."

 S DIR(0)="Y",DIR("A")="Print Summary Only",DIR("B")="YES" D ^DIR K DIR

 I $D(DIRUT) G END

 S IBSUM=Y

 G:IBSUM DATE

 ; -- ask what types of care to include

 D TYPE^IBTODD2 I IBSELECT<1 G END

 ; -- ask how they want inpatient sorted

 I IBSELECT[1 D SORT^IBTODD2 I IBSORT<0 G END

DATE ; -- select date range

 W ! D DATE^IBOUTL

 I IBBDT=""!(IBEDT="") G END

DEV ; -- select device, run option

W !

 I 'IBSUM W !!,"You will need a 132 column printer for this report!",!

 S %ZIS="QM" D ^%ZIS G:POP END

 I $D(IO("Q")) S ZTRTN="DQ^IBTODD",ZTSAVE("IB*")="",ZTDESC="IB - Denied Days Report" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END

 U IO

 D DQ G END

END ; -- Clean up

 W ! K ^TMP($J,"IBTODD")

 I $D(ZTQUEUED) S ZTREQ="@" Q

 D ^%ZISC

 K I,J,X,X2,Y,DFN,%ZIS,DGPM,VA,IBI,IBJ,IBTRN,IBTRND,IBTRND1,IBPAG,IBHDT,IBDISDT,IBETYP,IBQUIT,IBTAG,IBTRC,IBTRCD,IBDEN,IBDAY,IBTALL,IBADM,IBDISCH,IBMAX

 K IBAPL,IBBBS,IBBDT,IBC,IBCDT,IBCNT,IBDT,IBD,IBDATA,IBEDT,IBNAM,IBPRIM,IBPROV,IBRATE,IBSECN,IBSERV,IBSORT,IBSPEC,IBSUM,IBSUBT,IBTOTL,IBCNTO,IBEVNTYP,IBISV,IBSELECT

 D KVAR^VADPT

DQ ; -- entry print from taskman

 K ^TMP($J,"IBTODD") F I=1:1 S J=$P(IBSELECT,",",I) Q:'J  S ^TMP($J,"IBTODD",J)=""

 S X=132 X ^%ZOSF("RM")

 S IBPAG=0,IBHDT=$$HTE^XLFDT($H,1),IBQUIT=0

 S IBDEN=$O(^IBE(356.7,"ACODE",20,0))

 D BLD,PRINT^IBTODD1

 I $D(ZTQUEUED) G END

BLD ; -- sort through data and build array to print from

 S IBTRC=0

 F  S IBTRC=$O(^IBT(356.2,"ACT",IBDEN,IBTRC)) Q:'IBTRC  D

 .N IBDAY S IBTRCD=$G(^IBT(356.2,+IBTRC,0))

 .S IBTRN=$P(IBTRCD,"^",2),IBTRND=$G(^IBT(356,+IBTRN,0))

 .Q:'$P(IBTRCD,"^",19)  ; review is inactive

 .Q:'$P(IBTRND,"^",20)  ; parent CT entry is inactive

 .S IBEVNTYP=$P(IBTRND,U,18) S:IBEVNTYP=5 IBEVNTYP=1

. ;

 .I IBEVNTYP=1,IBSELECT[1 D  Q

 ..S IBDDB=$P(IBTRCD,"^",15),IBDDE=$P(IBTRCD,"^",16)

 ..S IBTALL=$P($G(^IBT(356.2,+IBTRC,1)),"^",7)

 ..S IBLOSI=$$LOS(IBTRN) ; admissions length of stay

 ..I IBDDB,IBDDE Q:(IBDDB>IBEDT)!(IBDDE<IBBDT)  D

 ...I IBDDB<IBBDT S IBDDB=IBBDT ; chk days denied in correct range

 ...I IBDDE>IBEDT S IBDDE=IBEDT

 ...S IBDAY=$$FMDIFF^XLFDT(IBDDE,IBDDB)+1 ; cals total denied days

 ..; if no days denied "to" and "from" and episode in range

 ..I (IBTALL),('$D(IBDAY)) S IBCDT=$$CDT^IBTODD1(IBTRN) D STRIP Q:('+IBCDT!(+IBCDT>IBEDT))  D

 ...;Q:'$P(IBTRND,U,5)  ; quit if no link between ct and dgpm

 ...I '$P(IBCDT,U,2) S $P(IBCDT,U,2)=$$FMADD^XLFDT($P(IBCDT,U,1),1) ; unlinked all to event dt+1 los

 ...; if the care date is >the report range there is no discharge add 1

 ...I '$P(IBCDT,U,2)!($P(IBCDT,U,2)>IBEDT) S $P(IBCDT,U,2)=$$FMADD^XLFDT(IBEDT,1)

 ...I +IBCDT<IBBDT S $P(IBCDT,U,1)=IBBDT

 ...S IBDAY=$$FMDIFF^XLFDT($P(IBCDT,U,2),$P(IBCDT,U,1))

 ..I IBLOSI=1,$G(IBDAY)=0 S IBDAY=1 ; get one day stays

 ..Q:$G(IBDAY)<1

 ..S DFN=$P(IBTRCD,"^",5),IBNAM=$P($G(^DPT(+DFN,0)),"^") Q:IBNAM=""

 ..S IBD=$$PROV(DFN,IBTRCD,IBTRND,IBTALL),IBPROV=+IBD,IBSPEC=$P(IBD,"^",2),IBSERV=$P(IBD,"^",3)

 ..;S IBBBS=$$BBS^IBTOSUM1($P(IBD,"^",2))

 ..;S IBRATE=$$RATE^IBTOSUM1(IBBBS,+IBTRCD)

 ..S IBRATE=$$AMOUNT^IBJDB21(1,IBTRN) ; get events charge

 ..I +IBLOSI,+IBRATE S IBRATE=(IBRATE/IBLOSI)*IBDAY ; calculate amount for days denied

 ..D SET

.;

 .I IBEVNTYP'=1,IBSELECT[IBEVNTYP D  Q

 ..S IBDDB=$P(IBTRND,"^",6)

 ..Q:(IBDDB<IBBDT)!(IBDDB>IBEDT)

 ..S DFN=$P(IBTRCD,"^",5),IBNAM=$P($G(^DPT(+DFN,0)),"^") Q:IBNAM=""

 ..S IBPROV=0,IBSPEC=0,IBSERV=$S(IBEVNTYP=2:"OUTPATIENT",IBEVNTYP=3:"PROSTHETICS",IBEVNTYP=4:"PRESCRIPTION",1:"UNKNOWN")

 ..S IBDAY=1,IBRATE=$$AMOUNT^IBJDB21(IBEVNTYP,IBTRN) ; get events charge

 ..D SET

 K IBTRN,IBTRND,IBTRCD,DFN,IBDDB,IBDDE,IBCDT,IBLOSI

SET ; -- set array to print from

 ; -- ^tmp($j,"ibtodd",evnt typ,primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^  ^ billing rate^ no. days denied

 S IBPRIM=$S(IBSORT="P":IBNAM,IBSORT="A":IBPROV,1:IBSERV)

 S IBSECN=$S(IBSORT="P":IBPROV,1:IBNAM)

 I IBEVNTYP'=1 S IBPRIM=IBNAM,IBSECN=IBDDB

 S:IBPRIM="" IBPRIM="UNKNOWN" S:IBSECN="" IBSECN="UNKNOWN"

 S ^TMP($J,"IBTODD",IBEVNTYP,IBPRIM,IBSECN,IBTRC)=DFN_"^"_IBPROV_"^"_IBSPEC_"^"_IBSERV_"^^"_IBRATE_"^"_IBDAY

PROV(DFN,IBTRCD,IBTRND,IBTALL) ; Find attending/serv/spec during the denied period

 ;  Input:    DFN  --  Pointer to the patient in file #2

 ;         IBTRCD  --  Zeroth node of insurance review in file #356.2

 ;         IBTRND  --  Zeroth node of parent CT entry in file #356

 ;         IBTALL  --  1=> deny entire admission

 ; Output:  1^2^3, where   1 => pointer to attending in file #200

 ;                         2 => pointer to treating spec. in file #45.7

 ;                         3 => service abbr. code

 N I,J,X,Y,DGPM,IBD,VA200,VAIN,VAIP,VAERR

 ; - determine date/time to calculate attending/serv/spec

 S DGPM=+$P(IBTRND,"^",5),IBD=+$G(^DGPM(DGPM,0))

 S:'IBD IBD=$P(IBTRND,"^",6)

 I IBTALL S Y=IBD

 I 'IBTALL D

 .I $P(IBTRCD,"^",16)>$P(IBTRCD,"^",15) S Y=$P(IBTRCD,"^",15)_.2359 Q

 .I $P(IBTRCD,"^",15)=(IBD\1) S Y=IBD Q

 .S VAIP("D")=$P(IBTRCD,"^",15) D IN5^VADPT

 .I +VAIP(16,1)\1=$P(IBTRCD,"^",15) S Y=+VAIP(16,1) Q

 .S Y=$P(IBTRCD,"^",15)

 S VA200="",VAINDT=Y D INP^VADPT

 S X=+VAIN(11)

 S Y=$G(^IBT(356.94,+$O(^IBT(356.94,"ATP",+DGPM,1,0)),0))

 S:$P(Y,"^",3) X=$P(Y,"^",3)

PROVQ Q X_"^"_+VAIN(3)_"^"_$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+$G(VAIN(3)),0)),"^",2),0)),"^",3)

STRIP ; -- strip time from dates (if report run same day time could produce incorrect results)

 S $P(IBCDT,U,1)=$P(IBCDT,".",1),$P(IBCDT,U,2)=$P($P(IBCDT,U,2),".",1) Q

LOS(IBTRN) ; compute admissions length of stay

 N X,Y,DGPM,BEG,END,LOS S X=$G(^IBT(356,+$G(IBTRN),0)),LOS=0,Y=0

 I $P(X,"^",5) S DGPM=$G(^DGPM($P(X,"^",5),0)) D

 . S BEG=+DGPM,END=DT

 . I $P(DGPM,"^",17) S END=+$G(^DGPM($P(DGPM,"^",17),0))

 . S LOS=$$FMDIFF^XLFDT(END,BEG)

 . I (BEG\1)=(END\1) S LOS=1

 I +LOS S Y=+LOS

Q Y

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTODD   6301     printed  Mar 13, 2025@21:32:15                                                                                                                                                                                                      Page 2

IBTODD    ;ALB/AAS - CLAIMS TRACKING DENIED DAYS REPORT ; 27-OCT-93

 +1       ;;2.0;INTEGRATED BILLING;**32,458,730**;21-MAR-94;Build 83

 +2       ;

%          IF '$DATA(DT)

               DO DT^DICRW

 +1        WRITE !!,"Denied Days Report",!!

 +2       ;

 +3        SET IBSORT="P"

           SET IBSELECT="1,2,3,4,"

 +4        NEW DIR

 +5        SET DIR("?")="Answer YES if you only want to print a summary or answer NO if you want a detailed listing plus the summary."

 +6        SET DIR(0)="Y"

           SET DIR("A")="Print Summary Only"

           SET DIR("B")="YES"

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               GOTO END

 +8        SET IBSUM=Y

 +9        if IBSUM

               GOTO DATE

 +10      ;

 +11      ; -- ask what types of care to include

 +12       DO TYPE^IBTODD2

           IF IBSELECT<1

               GOTO END

 +13      ;

 +14      ; -- ask how they want inpatient sorted

 +15       IF IBSELECT[1

               DO SORT^IBTODD2

               IF IBSORT<0

                   GOTO END

 +16      ;

DATE      ; -- select date range

 +1        WRITE !

           DO DATE^IBOUTL

 +2        IF IBBDT=""!(IBEDT="")

               GOTO END

 +3       ;

DEV       ; -- select device, run option

 +1        WRITE !

 +2        IF 'IBSUM

               WRITE !!,"You will need a 132 column printer for this report!",!

 +3        SET %ZIS="QM"

           DO ^%ZIS

           if POP

               GOTO END

 +4        IF $DATA(IO("Q"))

               SET ZTRTN="DQ^IBTODD"

               SET ZTSAVE("IB*")=""

               SET ZTDESC="IB - Denied Days Report"

               DO ^%ZTLOAD

               KILL IO("Q"),ZTSK

               DO HOME^%ZIS

               GOTO END

 +5       ;

 +6        USE IO

 +7        DO DQ

           GOTO END

 +8        QUIT

 +9       ;

END       ; -- Clean up

 +1        WRITE !

           KILL ^TMP($JOB,"IBTODD")

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT

 +3        DO ^%ZISC

 +4        KILL I,J,X,X2,Y,DFN,%ZIS,DGPM,VA,IBI,IBJ,IBTRN,IBTRND,IBTRND1,IBPAG,IBHDT,IBDISDT,IBETYP,IBQUIT,IBTAG,IBTRC,IBTRCD,IBDEN,IBDAY,IBTALL,IBADM,IBDISCH,IBMAX

 +5        KILL IBAPL,IBBBS,IBBDT,IBC,IBCDT,IBCNT,IBDT,IBD,IBDATA,IBEDT,IBNAM,IBPRIM,IBPROV,IBRATE,IBSECN,IBSERV,IBSORT,IBSPEC,IBSUM,IBSUBT,IBTOTL,IBCNTO,IBEVNTYP,IBISV,IBSELECT

 +6        DO KVAR^VADPT

 +7        QUIT

DQ        ; -- entry print from taskman

 +1        KILL ^TMP($JOB,"IBTODD")

           FOR I=1:1

               SET J=$PIECE(IBSELECT,",",I)

               if 'J

                   QUIT

               SET ^TMP($JOB,"IBTODD",J)=""

 +2        SET X=132

           XECUTE ^%ZOSF("RM")

 +3        SET IBPAG=0

           SET IBHDT=$$HTE^XLFDT($HOROLOG,1)

           SET IBQUIT=0

 +4        SET IBDEN=$ORDER(^IBE(356.7,"ACODE",20,0))

 +5        DO BLD

           DO PRINT^IBTODD1

 +6        IF $DATA(ZTQUEUED)

               GOTO END

 +7        QUIT

 +8       ;

BLD       ; -- sort through data and build array to print from

 +1       ;

 +2        SET IBTRC=0

 +3        FOR

               SET IBTRC=$ORDER(^IBT(356.2,"ACT",IBDEN,IBTRC))

               if 'IBTRC

                   QUIT

               Begin DoDot:1

 +4                NEW IBDAY

                   SET IBTRCD=$GET(^IBT(356.2,+IBTRC,0))

 +5                SET IBTRN=$PIECE(IBTRCD,"^",2)

                   SET IBTRND=$GET(^IBT(356,+IBTRN,0))

 +6       ; review is inactive

                   if '$PIECE(IBTRCD,"^",19)

                       QUIT

 +7       ; parent CT entry is inactive

                   if '$PIECE(IBTRND,"^",20)

                       QUIT

 +8                SET IBEVNTYP=$PIECE(IBTRND,U,18)

                   if IBEVNTYP=5

                       SET IBEVNTYP=1

 +9       ;

 +10               IF IBEVNTYP=1

                       IF IBSELECT[1

                           Begin DoDot:2

 +11                           SET IBDDB=$PIECE(IBTRCD,"^",15)

                               SET IBDDE=$PIECE(IBTRCD,"^",16)

 +12                           SET IBTALL=$PIECE($GET(^IBT(356.2,+IBTRC,1)),"^",7)

 +13      ; admissions length of stay

                               SET IBLOSI=$$LOS(IBTRN)

 +14                           IF IBDDB

                                   IF IBDDE

                                       if (IBDDB>IBEDT)!(IBDDE<IBBDT)

                                           QUIT

                                       Begin DoDot:3

 +15      ; chk days denied in correct range

                                           IF IBDDB<IBBDT

                                               SET IBDDB=IBBDT

 +16                                       IF IBDDE>IBEDT

                                               SET IBDDE=IBEDT

 +17      ; cals total denied days

                                           SET IBDAY=$$FMDIFF^XLFDT(IBDDE,IBDDB)+1

                                       End DoDot:3

 +18      ; if no days denied "to" and "from" and episode in range

 +19                           IF (IBTALL)

                                   IF ('$DATA(IBDAY))

                                       SET IBCDT=$$CDT^IBTODD1(IBTRN)

                                       DO STRIP

                                       if ('+IBCDT!(+IBCDT>IBEDT))

                                           QUIT

                                       Begin DoDot:3

 +20      ;Q:'$P(IBTRND,U,5)  ; quit if no link between ct and dgpm

 +21      ; unlinked all to event dt+1 los

                                           IF '$PIECE(IBCDT,U,2)

                                               SET $PIECE(IBCDT,U,2)=$$FMADD^XLFDT($PIECE(IBCDT,U,1),1)

 +22      ; if the care date is >the report range there is no discharge add 1

 +23                                       IF '$PIECE(IBCDT,U,2)!($PIECE(IBCDT,U,2)>IBEDT)

                                               SET $PIECE(IBCDT,U,2)=$$FMADD^XLFDT(IBEDT,1)

 +24                                       IF +IBCDT<IBBDT

                                               SET $PIECE(IBCDT,U,1)=IBBDT

 +25                                       SET IBDAY=$$FMDIFF^XLFDT($PIECE(IBCDT,U,2),$PIECE(IBCDT,U,1))

                                       End DoDot:3

 +26      ; get one day stays

                               IF IBLOSI=1

                                   IF $GET(IBDAY)=0

                                       SET IBDAY=1

 +27                           if $GET(IBDAY)<1

                                   QUIT

 +28                           SET DFN=$PIECE(IBTRCD,"^",5)

                               SET IBNAM=$PIECE($GET(^DPT(+DFN,0)),"^")

                               if IBNAM=""

                                   QUIT

 +29                           SET IBD=$$PROV(DFN,IBTRCD,IBTRND,IBTALL)

                               SET IBPROV=+IBD

                               SET IBSPEC=$PIECE(IBD,"^",2)

                               SET IBSERV=$PIECE(IBD,"^",3)

 +30      ;S IBBBS=$$BBS^IBTOSUM1($P(IBD,"^",2))

 +31      ;S IBRATE=$$RATE^IBTOSUM1(IBBBS,+IBTRCD)

 +32      ; get events charge

                               SET IBRATE=$$AMOUNT^IBJDB21(1,IBTRN)

 +33      ; calculate amount for days denied

                               IF +IBLOSI

                                   IF +IBRATE

                                       SET IBRATE=(IBRATE/IBLOSI)*IBDAY

 +34                           DO SET

                           End DoDot:2

                           QUIT

 +35      ;

 +36               IF IBEVNTYP'=1

                       IF IBSELECT[IBEVNTYP

                           Begin DoDot:2

 +37                           SET IBDDB=$PIECE(IBTRND,"^",6)

 +38                           if (IBDDB<IBBDT)!(IBDDB>IBEDT)

                                   QUIT

 +39                           SET DFN=$PIECE(IBTRCD,"^",5)

                               SET IBNAM=$PIECE($GET(^DPT(+DFN,0)),"^")

                               if IBNAM=""

                                   QUIT

 +40                           SET IBPROV=0

                               SET IBSPEC=0

                               SET IBSERV=$SELECT(IBEVNTYP=2:"OUTPATIENT",IBEVNTYP=3:"PROSTHETICS",IBEVNTYP=4:"PRESCRIPTION",1:"UNKNOWN")

 +41      ; get events charge

                               SET IBDAY=1

                               SET IBRATE=$$AMOUNT^IBJDB21(IBEVNTYP,IBTRN)

 +42                           DO SET

                           End DoDot:2

                           QUIT

               End DoDot:1

 +43       KILL IBTRN,IBTRND,IBTRCD,DFN,IBDDB,IBDDE,IBCDT,IBLOSI

 +44       QUIT

 +45      ;

SET       ; -- set array to print from

 +1       ; -- ^tmp($j,"ibtodd",evnt typ,primary sort,secondary sort,ibtrc)=DFN ^ attending ^ treating specialty ^ service ^  ^ billing rate^ no. days denied

 +2        SET IBPRIM=$SELECT(IBSORT="P":IBNAM,IBSORT="A":IBPROV,1:IBSERV)

 +3        SET IBSECN=$SELECT(IBSORT="P":IBPROV,1:IBNAM)

 +4        IF IBEVNTYP'=1

               SET IBPRIM=IBNAM

               SET IBSECN=IBDDB

 +5        if IBPRIM=""

               SET IBPRIM="UNKNOWN"

           if IBSECN=""

               SET IBSECN="UNKNOWN"

 +6        SET ^TMP($JOB,"IBTODD",IBEVNTYP,IBPRIM,IBSECN,IBTRC)=DFN_"^"_IBPROV_"^"_IBSPEC_"^"_IBSERV_"^^"_IBRATE_"^"_IBDAY

 +7        QUIT

 +8       ;

PROV(DFN,IBTRCD,IBTRND,IBTALL) ; Find attending/serv/spec during the denied period

 +1       ;  Input:    DFN  --  Pointer to the patient in file #2

 +2       ;         IBTRCD  --  Zeroth node of insurance review in file #356.2

 +3       ;         IBTRND  --  Zeroth node of parent CT entry in file #356

 +4       ;         IBTALL  --  1=> deny entire admission

 +5       ; Output:  1^2^3, where   1 => pointer to attending in file #200

 +6       ;                         2 => pointer to treating spec. in file #45.7

 +7       ;                         3 => service abbr. code

 +8       ;

 +9        NEW I,J,X,Y,DGPM,IBD,VA200,VAIN,VAIP,VAERR

 +10      ;

 +11      ; - determine date/time to calculate attending/serv/spec

 +12       SET DGPM=+$PIECE(IBTRND,"^",5)

           SET IBD=+$GET(^DGPM(DGPM,0))

 +13       if 'IBD

               SET IBD=$PIECE(IBTRND,"^",6)

 +14       IF IBTALL

               SET Y=IBD

 +15       IF 'IBTALL

               Begin DoDot:1

 +16               IF $PIECE(IBTRCD,"^",16)>$PIECE(IBTRCD,"^",15)

                       SET Y=$PIECE(IBTRCD,"^",15)_.2359

                       QUIT

 +17               IF $PIECE(IBTRCD,"^",15)=(IBD\1)

                       SET Y=IBD

                       QUIT

 +18               SET VAIP("D")=$PIECE(IBTRCD,"^",15)

                   DO IN5^VADPT

 +19               IF +VAIP(16,1)\1=$PIECE(IBTRCD,"^",15)

                       SET Y=+VAIP(16,1)

                       QUIT

 +20               SET Y=$PIECE(IBTRCD,"^",15)

               End DoDot:1

 +21       SET VA200=""

           SET VAINDT=Y

           DO INP^VADPT

 +22      ;

 +23       SET X=+VAIN(11)

 +24       SET Y=$GET(^IBT(356.94,+$ORDER(^IBT(356.94,"ATP",+DGPM,1,0)),0))

 +25       if $PIECE(Y,"^",3)

               SET X=$PIECE(Y,"^",3)

PROVQ      QUIT X_"^"_+VAIN(3)_"^"_$PIECE($GET(^DIC(42.4,+$PIECE($GET(^DIC(45.7,+$GET(VAIN(3)),0)),"^",2),0)),"^",3)

 +1       ;

STRIP     ; -- strip time from dates (if report run same day time could produce incorrect results)

 +1        SET $PIECE(IBCDT,U,1)=$PIECE(IBCDT,".",1)

           SET $PIECE(IBCDT,U,2)=$PIECE($PIECE(IBCDT,U,2),".",1)

           QUIT

 +2       ;

LOS(IBTRN) ; compute admissions length of stay

 +1        NEW X,Y,DGPM,BEG,END,LOS

           SET X=$GET(^IBT(356,+$GET(IBTRN),0))

           SET LOS=0

           SET Y=0

 +2        IF $PIECE(X,"^",5)

               SET DGPM=$GET(^DGPM($PIECE(X,"^",5),0))

               Begin DoDot:1

 +3                SET BEG=+DGPM

                   SET END=DT

 +4                IF $PIECE(DGPM,"^",17)

                       SET END=+$GET(^DGPM($PIECE(DGPM,"^",17),0))

 +5                SET LOS=$$FMDIFF^XLFDT(END,BEG)

 +6                IF (BEG\1)=(END\1)

                       SET LOS=1

               End DoDot:1

 +7        IF +LOS

               SET Y=+LOS

 +8        QUIT Y

IBTODD.m