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 ---[H[J[2J[HIBYZ20R 3752 printed Nov 22, 2024@17:47:01 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
