IBYZ20R.m

IBYZ20R ;ALB/CPM - FIX CT ENTRIES FOR PATCH IB*2*62 ; 13-JUN-96

 ;;Version 2.0 ; INTEGRATED BILLING ;**62**; 21-MAR-94

 ;

 D ID ; update the Procedures (#399.0304) identifier

 D CT ; remove scheduled admission pointers in Claims Tracking

 Q

 ;

 ;

CT ; Remove Scheduled Admission pointer from Claims Tracking entries.

 S X(1)=">>> Examining all CT entries with a Scheduled Admission pointer..."

 S X(2)=" " D BMES^XPDUTL(.X)

 ;

 S (IBDELS,IBSCHA)=0 K ^TMP($J,"IBT")

 S IBSCH=0 F  S IBSCH=$O(^IBT(356,"ASCH",IBSCH)) Q:'IBSCH  D

 .S IBTRN=0 F  S IBTRN=$O(^IBT(356,"ASCH",IBSCH,IBTRN)) Q:'IBTRN  D

 ..;

 ..; - if there is no CT entry, kill x-ref and quit

 ..S IBTRND=$G(^IBT(356,IBTRN,0))

 ..I IBTRND="" K ^IBT(356,"ASCH",IBSCH,IBTRN) Q

 ..;

 ..; - if the CT entry is inactive, delete the SA ptr and quit

 ..I '$P(IBTRND,"^",20) D INAC Q

 ..;

 ..; - get the CT admission ptr, event date, DFN

 ..S IBADM=$P(IBTRND,"^",5),IBCTED=$P(IBTRND,"^",6),DFN=$P(IBTRND,"^",2)

 ..;

 ..; - if there's no adm ptr, check to see if the CT entry should

 ..;   be inactivated (with the SA ptr deleted).  Otherwise, it's

 ..;   a valid SA CT entry, just waiting for the vet to be admitted.

 ..I 'IBADM D  Q

 ...S IBSCHD=$G(^DGS(41.1,IBSCH,0))

 ...;

 ...; - got a dangling ptr

 ...I IBSCHD="" D INAC Q

 ...;

 ...; - SA is cancelled or already admitted

 ...I $P(IBSCHD,"^",13)!$P(IBSCHD,"^",17) D INAC Q

 ...;

 ...; - the SA patient is not the same as the CT patient

 ...I +IBSCHD'=DFN D INAC Q

 ...;

 ...; - the SA day is not the same as the CT Event day

 ...I $P($P(IBSCHD,"^",2),".")'=$P(IBCTED,".") D INAC Q

 ...;

 ...; - valid SA CT entry

 ...S IBSCHA=IBSCHA+1

 ...Q

 ..;

 ..; - CT entry has an adm ptr; the SA ptr will be deleted.

 ..;

 ..; - if the CT has an IR dated 21 days prior to the CT event date,

 ..;   or a HR dated prior to the CT event date, the CT is suspect.

 ..S (IBSTOP,IBTRC)=0 F  S IBTRC=$O(^IBT(356.2,"C",IBTRN,IBTRC)) Q:'IBTRC  S IBDATE=+$G(^IBT(356.2,IBTRC,0))\1 I $$FMDIFF^XLFDT(IBCTED\1,IBDATE)>21 S IBSTOP="1^IR: "_$$DAT1^IBOUTL(IBDATE) Q

 ..;

 ..I 'IBSTOP S IBTRV=0 F  S IBTRV=$O(^IBT(356.1,"C",IBTRN,IBTRV)) Q:'IBTRV  S IBDATE=+$G(^IBT(356.1,IBTRV,0))\1 I $$FMDIFF^XLFDT(IBCTED\1,IBDATE)>0 S IBSTOP="1^HR: "_$$DAT1^IBOUTL(IBDATE) Q

 ..;

 ..I IBSTOP S ^TMP($J,"IBT",IBTRN)=DFN_"^"_$P(IBSTOP,"^",2)

 ..;

 ..; - delete the ptr

 ..S DA=IBTRN,DR=".32///@",DIE="^IBT(356," D ^DIE K DA,DR,DIE

 ..S IBDELS=IBDELS+1

 ;

 ;

 D BMES^XPDUTL("Scheduled Admission pointers were deleted from "_IBDELS_" entries.")

 D BMES^XPDUTL("Found "_IBSCHA_" valid SA CT entries awaiting admission.")

 D LIST

 K ^TMP($J,"IBT"),IBSCHA,IBSCH,IBSCHD,IBTRN,IBDATE,IBTRND,IBSTOP,IBTRC,IBTRV,DFN,IBADM,IBCTED,IBDELS,X,Y

 Q

 ;

 ;

INAC ; Inactivate a CT entry and delete the Sched Adm ptr.

 S DA=IBTRN,DR=".2////0;.32///@",DIE="^IBT(356,"

 D ^DIE K DA,DR,DIE S IBDELS=IBDELS+1

 Q

 ;

LIST ; List CT entries which may have been overlaid.

 N IBTRN,X,Y S X(1)=" "

 I '$D(^TMP($J,"IBT")) D  G LISTQ

 .S X(2)="Didn't find any CT entries which may have been overlaid."

 .D BMES^XPDUTL(.X)

 S X(2)="List of CT entries to be checked:"

 S X(3)="---------------------------------"

 D BMES^XPDUTL(.X) K X

 S IBTRN=0 F  S IBTRN=$O(^TMP($J,"IBT",IBTRN)) Q:'IBTRN  S Y=$G(^(IBTRN)) D

 .S X=$E($E($P($G(^DPT(+Y,0)),"^"),1,25)_" ("_$E($P($G(^(0)),"^",9),6,10)_")"_$J("",35),1,35)

 .S X=X_"CT ien: "_IBTRN_" ("_$$DAT1^IBOUTL(IBCTED)_")    "_$P(Y,"^",2)

 .D MES^XPDUTL(X)

LISTQ Q

 ;

 ;

ID ; Set the identifier for the Procedures (#399.0304) sub-file.

 N X

 S X(1)=">>> Updating the Procedures (#399.0304) identifier..."

 S X(2)=" " D BMES^XPDUTL(.X)

 S ^DD(399.0304,0,"ID","WRITE")="D DISPID^IBCSC4D"

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBYZ20R   3752     printed  Mar 13, 2025@21:42:13                                                                                                                                                                                                     Page 2

IBYZ20R   ;ALB/CPM - FIX CT ENTRIES FOR PATCH IB*2*62 ; 13-JUN-96

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;**62**; 21-MAR-94

 +2       ;

 +3       ; update the Procedures (#399.0304) identifier

           DO ID

 +4       ; remove scheduled admission pointers in Claims Tracking

           DO CT

 +5        QUIT 

 +6       ;

 +7       ;

CT        ; Remove Scheduled Admission pointer from Claims Tracking entries.

 +1        SET X(1)=">>> Examining all CT entries with a Scheduled Admission pointer..."

 +2        SET X(2)=" "

           DO BMES^XPDUTL(.X)

 +3       ;

 +4        SET (IBDELS,IBSCHA)=0

           KILL ^TMP($JOB,"IBT")

 +5        SET IBSCH=0

           FOR 

               SET IBSCH=$ORDER(^IBT(356,"ASCH",IBSCH))

               if 'IBSCH

                   QUIT 

               Begin DoDot:1

 +6                SET IBTRN=0

                   FOR 

                       SET IBTRN=$ORDER(^IBT(356,"ASCH",IBSCH,IBTRN))

                       if 'IBTRN

                           QUIT 

                       Begin DoDot:2

 +7       ;

 +8       ; - if there is no CT entry, kill x-ref and quit

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

 +10                       IF IBTRND=""

                               KILL ^IBT(356,"ASCH",IBSCH,IBTRN)

                               QUIT 

 +11      ;

 +12      ; - if the CT entry is inactive, delete the SA ptr and quit

 +13                       IF '$PIECE(IBTRND,"^",20)

                               DO INAC

                               QUIT 

 +14      ;

 +15      ; - get the CT admission ptr, event date, DFN

 +16                       SET IBADM=$PIECE(IBTRND,"^",5)

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

                           SET DFN=$PIECE(IBTRND,"^",2)

 +17      ;

 +18      ; - if there's no adm ptr, check to see if the CT entry should

 +19      ;   be inactivated (with the SA ptr deleted).  Otherwise, it's

 +20      ;   a valid SA CT entry, just waiting for the vet to be admitted.

 +21                       IF 'IBADM

                               Begin DoDot:3

 +22                               SET IBSCHD=$GET(^DGS(41.1,IBSCH,0))

 +23      ;

 +24      ; - got a dangling ptr

 +25                               IF IBSCHD=""

                                       DO INAC

                                       QUIT 

 +26      ;

 +27      ; - SA is cancelled or already admitted

 +28                               IF $PIECE(IBSCHD,"^",13)!$PIECE(IBSCHD,"^",17)

                                       DO INAC

                                       QUIT 

 +29      ;

 +30      ; - the SA patient is not the same as the CT patient

 +31                               IF +IBSCHD'=DFN

                                       DO INAC

                                       QUIT 

 +32      ;

 +33      ; - the SA day is not the same as the CT Event day

 +34                               IF $PIECE($PIECE(IBSCHD,"^",2),".")'=$PIECE(IBCTED,".")

                                       DO INAC

                                       QUIT 

 +35      ;

 +36      ; - valid SA CT entry

 +37                               SET IBSCHA=IBSCHA+1

 +38                               QUIT 

                               End DoDot:3

                               QUIT 

 +39      ;

 +40      ; - CT entry has an adm ptr; the SA ptr will be deleted.

 +41      ;

 +42      ; - if the CT has an IR dated 21 days prior to the CT event date,

 +43      ;   or a HR dated prior to the CT event date, the CT is suspect.

 +44                       SET (IBSTOP,IBTRC)=0

                           FOR 

                               SET IBTRC=$ORDER(^IBT(356.2,"C",IBTRN,IBTRC))

                               if 'IBTRC

                                   QUIT 

                               SET IBDATE=+$GET(^IBT(356.2,IBTRC,0))\1

                               IF $$FMDIFF^XLFDT(IBCTED\1,IBDATE)>21

                                   SET IBSTOP="1^IR: "_$$DAT1^IBOUTL(IBDATE)

                                   QUIT 

 +45      ;

 +46                       IF 'IBSTOP

                               SET IBTRV=0

                               FOR 

                                   SET IBTRV=$ORDER(^IBT(356.1,"C",IBTRN,IBTRV))

                                   if 'IBTRV

                                       QUIT 

                                   SET IBDATE=+$GET(^IBT(356.1,IBTRV,0))\1

                                   IF $$FMDIFF^XLFDT(IBCTED\1,IBDATE)>0

                                       SET IBSTOP="1^HR: "_$$DAT1^IBOUTL(IBDATE)

                                       QUIT 

 +47      ;

 +48                       IF IBSTOP

                               SET ^TMP($JOB,"IBT",IBTRN)=DFN_"^"_$PIECE(IBSTOP,"^",2)

 +49      ;

 +50      ; - delete the ptr

 +51                       SET DA=IBTRN

                           SET DR=".32///@"

                           SET DIE="^IBT(356,"

                           DO ^DIE

                           KILL DA,DR,DIE

 +52                       SET IBDELS=IBDELS+1

                       End DoDot:2

               End DoDot:1

 +53      ;

 +54      ;

 +55       DO BMES^XPDUTL("Scheduled Admission pointers were deleted from "_IBDELS_" entries.")

 +56       DO BMES^XPDUTL("Found "_IBSCHA_" valid SA CT entries awaiting admission.")

 +57       DO LIST

 +58       KILL ^TMP($JOB,"IBT"),IBSCHA,IBSCH,IBSCHD,IBTRN,IBDATE,IBTRND,IBSTOP,IBTRC,IBTRV,DFN,IBADM,IBCTED,IBDELS,X,Y

 +59       QUIT 

 +60      ;

 +61      ;

INAC      ; Inactivate a CT entry and delete the Sched Adm ptr.

 +1        SET DA=IBTRN

           SET DR=".2////0;.32///@"

           SET DIE="^IBT(356,"

 +2        DO ^DIE

           KILL DA,DR,DIE

           SET IBDELS=IBDELS+1

 +3        QUIT 

 +4       ;

LIST      ; List CT entries which may have been overlaid.

 +1        NEW IBTRN,X,Y

           SET X(1)=" "

 +2        IF '$DATA(^TMP($JOB,"IBT"))

               Begin DoDot:1

 +3                SET X(2)="Didn't find any CT entries which may have been overlaid."

 +4                DO BMES^XPDUTL(.X)

               End DoDot:1

               GOTO LISTQ

 +5        SET X(2)="List of CT entries to be checked:"

 +6        SET X(3)="---------------------------------"

 +7        DO BMES^XPDUTL(.X)

           KILL X

 +8        SET IBTRN=0

           FOR 

               SET IBTRN=$ORDER(^TMP($JOB,"IBT",IBTRN))

               if 'IBTRN

                   QUIT 

               SET Y=$GET(^(IBTRN))

               Begin DoDot:1

 +9                SET X=$EXTRACT($EXTRACT($PIECE($GET(^DPT(+Y,0)),"^"),1,25)_" ("_$EXTRACT($PIECE($GET(^(0)),"^",9),6,10)_")"_$JUSTIFY("",35),1,35)

 +10               SET X=X_"CT ien: "_IBTRN_" ("_$$DAT1^IBOUTL(IBCTED)_")    "_$PIECE(Y,"^",2)

 +11               DO MES^XPDUTL(X)

               End DoDot:1

LISTQ      QUIT 

 +1       ;

 +2       ;

ID        ; Set the identifier for the Procedures (#399.0304) sub-file.

 +1        NEW X

 +2        SET X(1)=">>> Updating the Procedures (#399.0304) identifier..."

 +3        SET X(2)=" "

           DO BMES^XPDUTL(.X)

 +4        SET ^DD(399.0304,0,"ID","WRITE")="D DISPID^IBCSC4D"

 +5        QUIT