PXDELFIX ;BAY/RJV-CLEAN ENCOUNTERS POINTING TO VISITS THAT DON'T EXIST PART 2. ;14-JUN-2005
;;1.0;PCE;**153**;14-JUL-2004
Q
;**********************************************************
;Two entry points. FIXALL and FIXIND. Called from PXDELENC.
;**********************************************************
FIXALL ; Fix all encounters.
N DA,DIK,PXPAT,PXSDATE,PXENC,PXSEC,PXCOUNT,PXPATNM,Y
S PXPAT="",PXSDATE="",PXENC=""
S PXCOUNT=$G(^XTMP("PXDELENC","PXENC","PXCOUNT"))
I PXCOUNT=0 D Q
.W !!,"There are no build entries to correct!"
.D WAIT^PXDELENC
I $G(^XTMP("PXDELENC","END BUILD"))="RUNNING" D Q
.W !!,"Build is running, please wait until complete!"
.D WAIT^PXDELENC
W !!,"There are "_$G(PXCOUNT)_" entries to correct."
S DIR("A")="Do you wish to continue? "
S DIR(0)="Y",DIR("B")="YES"
D ^DIR Q:$D(DIRUT)
Q:Y=0
K DIR,DA,DIRUT
F S PXPAT=$O(^XTMP("PXDELENC","PXENC",PXPAT)) Q:PXPAT="" D
.F S PXSDATE=$O(^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE)) Q:PXSDATE="" D
..F S PXENC=$O(^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE,PXENC)) Q:PXENC="" D
...S PXSEC=$G(^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE,PXENC))
...S PXPATNM=$P($G(^DPT(PXPAT,0)),"^",1)
...S $P(^DPT(PXPAT,"S",PXSDATE,0),"^",2)="NT"
...S $P(^DPT(PXPAT,"S",PXSDATE,0),"^",20)=""
...S DIK="^SCE(",DA=PXENC D ^DIK
...I $G(PXSEC)'="" S DIK="^SCE(",DA=PXSEC D ^DIK
...S PXCOUNT=PXCOUNT-1
...K ^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE,PXENC)
...W !!,?3,"Encounter: ",?12,$G(PXENC)_" - "_$G(PXPATNM),?45," Fixed!",!
...S DA=PXPAT D FIXIHS
S ^XTMP("PXDELENC","PXENC","PXCOUNT")=PXCOUNT
D WAIT^PXDELENC
Q
FIXIND ; Fix individual encounters.
N PXPAT,PXSDATE,PXSDTE,PXENC,PXVISIT,PXPRIM,PXEXIST,PXCOUNT,DIC,PXSEC,Y
I $G(^XTMP("PXDELENC","END BUILD"))="RUNNING" D Q
.W !!,"Build is running, please wait until complete!"
.D WAIT^PXDELENC
S DIC(0)="AEMQ"
D ^DPTLK I Y=-1 Q
Q:$D(DIRUT)
S PXPAT=$P(Y,"^")
S PXSDATE=0,PXENC="",PXPRIM="",PXSEC="",PXEXIST=0
S PXCOUNT=$G(^XTMP("PXDELENC","PXENC","PXCOUNT"))
W !!,"Processing...."
D HEADER
DISPLAY ;
F S PXSDATE=$O(^SCE("ADFN",PXPAT,PXSDATE)) Q:PXSDATE=""!($D(DIRUT)) D Q:$D(DIRUT)
.F S PXENC=$O(^SCE("ADFN",PXPAT,PXSDATE,PXENC)) Q:PXENC=""!($D(DIRUT)) D
..S PXVISIT=$P($G(^SCE(PXENC,0)),"^",5)
..S PXPRIM=$P($G(^SCE(PXENC,0)),"^",6)
..I $G(PXVISIT)'="" Q
..I $G(PXPRIM)'="" Q
..I $G(PXVISIT)="",$G(PXPRIM)="",$D(^DPT(PXPAT,"S",PXSDATE,0)) D
...S Y=PXSDATE D DD^%DT S PXSDTE=Y,PXEXIST=1
...S PXPATNM=$P($G(^DPT(PXPAT,0)),"^",1)
...W ?3,PXPAT_" - "_PXPATNM,?35,PXSDTE,?55,PXENC,!
...S ^XTMP("PXDELENC","FIXIND",PXPAT,PXSDATE,PXENC)=""
I $G(PXEXIST)=0 G NONE
S DIR("A")="This will fix all entries for this Patient. Continue? "
S DIR(0)="Y",DIR("B")="YES"
D ^DIR
G:$D(DIRUT) FIXIND
K DIR,DA,DIRUT
I Y=0 G FIXIND
FIX ;
N PXPAT,PXSDTE,PXENC
S PXPAT="",PXSDTE="",PXENC=""
F S PXPAT=$O(^XTMP("PXDELENC","FIXIND",PXPAT)) Q:PXPAT="" D
.F S PXSDTE=$O(^XTMP("PXDELENC","FIXIND",PXPAT,PXSDTE)) Q:PXSDTE="" D
..F S PXENC=$O(^XTMP("PXDELENC","FIXIND",PXPAT,PXSDTE,PXENC)) Q:PXENC="" D
...S $P(^DPT(PXPAT,"S",PXSDTE,0),"^",20)=""
...S $P(^DPT(PXPAT,"S",PXSDTE,0),"^",2)="NT"
...I $P($G(^SCE(PXENC+1,0)),"^",6)=PXENC S PXSEC=PXENC+1
...S DIK="^SCE(",DA=PXENC D ^DIK
...I $G(PXSEC)'="" S DIK="^SCE(",DA=PXSEC D ^DIK
...I $D(^XTMP("PXDELENC","PXENC",PXPAT,PXSDTE,PXENC)) S PXCOUNT=PXCOUNT-1
...K ^XTMP("PXDELENC","PXENC",PXPAT,PXSDTE,PXENC)
...K ^XTMP("PXDELENC","FIXIND",PXPAT,PXSDTE,PXENC)
...W !!,?3,"Encounter: ",?12,$G(PXENC)_" - "_$G(PXPATNM),?45," Fixed!",!
...S DA=PXPAT D FIXIHS
S ^XTMP("PXDELENC","PXENC","PXCOUNT")=PXCOUNT
Q:$D(DIRUT)
I PXEXIST=1 D
.W !!,"No more missing visits to correct for this patient!"
.D WAIT^PXDELENC
NONE ;
I PXEXIST=0 D
.W !!,"No missing visits found for this patient!"
.D WAIT^PXDELENC
K ^XTMP("PXDELENC","FIXIND")
G FIXIND
Q
W !,?3,"Patient IEN - Name",?35,"Appt Date",?55,"Encounter"
W !,?3,"==================",?35,"=========",?55,"=========",!
Q
FIXIHS ; Will fix the IHS Patient (9000001) file entries.
N PX
S U="^"
D CHECK^PXXDPT Q:'$T
S PX=$P($G(^DPT(DA,0)),U,9)
D SETSSN^PXXDPT
K DR,DIE,DA,PXDA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXDELFIX 4250 printed Apr 09, 2024@21:32:18 Page 2
PXDELFIX ;BAY/RJV-CLEAN ENCOUNTERS POINTING TO VISITS THAT DON'T EXIST PART 2. ;14-JUN-2005
+1 ;;1.0;PCE;**153**;14-JUL-2004
+2 QUIT
+3 ;**********************************************************
+4 ;Two entry points. FIXALL and FIXIND. Called from PXDELENC.
+5 ;**********************************************************
FIXALL ; Fix all encounters.
+1 NEW DA,DIK,PXPAT,PXSDATE,PXENC,PXSEC,PXCOUNT,PXPATNM,Y
+2 SET PXPAT=""
SET PXSDATE=""
SET PXENC=""
+3 SET PXCOUNT=$GET(^XTMP("PXDELENC","PXENC","PXCOUNT"))
+4 IF PXCOUNT=0
Begin DoDot:1
+5 WRITE !!,"There are no build entries to correct!"
+6 DO WAIT^PXDELENC
End DoDot:1
QUIT
+7 IF $GET(^XTMP("PXDELENC","END BUILD"))="RUNNING"
Begin DoDot:1
+8 WRITE !!,"Build is running, please wait until complete!"
+9 DO WAIT^PXDELENC
End DoDot:1
QUIT
+10 WRITE !!,"There are "_$GET(PXCOUNT)_" entries to correct."
+11 SET DIR("A")="Do you wish to continue? "
+12 SET DIR(0)="Y"
SET DIR("B")="YES"
+13 DO ^DIR
if $DATA(DIRUT)
QUIT
+14 if Y=0
QUIT
+15 KILL DIR,DA,DIRUT
+16 FOR
SET PXPAT=$ORDER(^XTMP("PXDELENC","PXENC",PXPAT))
if PXPAT=""
QUIT
Begin DoDot:1
+17 FOR
SET PXSDATE=$ORDER(^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE))
if PXSDATE=""
QUIT
Begin DoDot:2
+18 FOR
SET PXENC=$ORDER(^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE,PXENC))
if PXENC=""
QUIT
Begin DoDot:3
+19 SET PXSEC=$GET(^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE,PXENC))
+20 SET PXPATNM=$PIECE($GET(^DPT(PXPAT,0)),"^",1)
+21 SET $PIECE(^DPT(PXPAT,"S",PXSDATE,0),"^",2)="NT"
+22 SET $PIECE(^DPT(PXPAT,"S",PXSDATE,0),"^",20)=""
+23 SET DIK="^SCE("
SET DA=PXENC
DO ^DIK
+24 IF $GET(PXSEC)'=""
SET DIK="^SCE("
SET DA=PXSEC
DO ^DIK
+25 SET PXCOUNT=PXCOUNT-1
+26 KILL ^XTMP("PXDELENC","PXENC",PXPAT,PXSDATE,PXENC)
+27 WRITE !!,?3,"Encounter: ",?12,$GET(PXENC)_" - "_$GET(PXPATNM),?45," Fixed!",!
+28 SET DA=PXPAT
DO FIXIHS
End DoDot:3
End DoDot:2
End DoDot:1
+29 SET ^XTMP("PXDELENC","PXENC","PXCOUNT")=PXCOUNT
+30 DO WAIT^PXDELENC
+31 QUIT
FIXIND ; Fix individual encounters.
+1 NEW PXPAT,PXSDATE,PXSDTE,PXENC,PXVISIT,PXPRIM,PXEXIST,PXCOUNT,DIC,PXSEC,Y
+2 IF $GET(^XTMP("PXDELENC","END BUILD"))="RUNNING"
Begin DoDot:1
+3 WRITE !!,"Build is running, please wait until complete!"
+4 DO WAIT^PXDELENC
End DoDot:1
QUIT
+5 SET DIC(0)="AEMQ"
+6 DO ^DPTLK
IF Y=-1
QUIT
+7 if $DATA(DIRUT)
QUIT
+8 SET PXPAT=$PIECE(Y,"^")
+9 SET PXSDATE=0
SET PXENC=""
SET PXPRIM=""
SET PXSEC=""
SET PXEXIST=0
+10 SET PXCOUNT=$GET(^XTMP("PXDELENC","PXENC","PXCOUNT"))
+11 WRITE !!,"Processing...."
+12 DO HEADER
DISPLAY ;
+1 FOR
SET PXSDATE=$ORDER(^SCE("ADFN",PXPAT,PXSDATE))
if PXSDATE=""!($DATA(DIRUT))
QUIT
Begin DoDot:1
+2 FOR
SET PXENC=$ORDER(^SCE("ADFN",PXPAT,PXSDATE,PXENC))
if PXENC=""!($DATA(DIRUT))
QUIT
Begin DoDot:2
+3 SET PXVISIT=$PIECE($GET(^SCE(PXENC,0)),"^",5)
+4 SET PXPRIM=$PIECE($GET(^SCE(PXENC,0)),"^",6)
+5 IF $GET(PXVISIT)'=""
QUIT
+6 IF $GET(PXPRIM)'=""
QUIT
+7 IF $GET(PXVISIT)=""
IF $GET(PXPRIM)=""
IF $DATA(^DPT(PXPAT,"S",PXSDATE,0))
Begin DoDot:3
+8 SET Y=PXSDATE
DO DD^%DT
SET PXSDTE=Y
SET PXEXIST=1
+9 SET PXPATNM=$PIECE($GET(^DPT(PXPAT,0)),"^",1)
+10 WRITE ?3,PXPAT_" - "_PXPATNM,?35,PXSDTE,?55,PXENC,!
+11 SET ^XTMP("PXDELENC","FIXIND",PXPAT,PXSDATE,PXENC)=""
End DoDot:3
End DoDot:2
End DoDot:1
if $DATA(DIRUT)
QUIT
+12 IF $GET(PXEXIST)=0
GOTO NONE
+13 SET DIR("A")="This will fix all entries for this Patient. Continue? "
+14 SET DIR(0)="Y"
SET DIR("B")="YES"
+15 DO ^DIR
+16 if $DATA(DIRUT)
GOTO FIXIND
+17 KILL DIR,DA,DIRUT
+18 IF Y=0
GOTO FIXIND
FIX ;
+1 NEW PXPAT,PXSDTE,PXENC
+2 SET PXPAT=""
SET PXSDTE=""
SET PXENC=""
+3 FOR
SET PXPAT=$ORDER(^XTMP("PXDELENC","FIXIND",PXPAT))
if PXPAT=""
QUIT
Begin DoDot:1
+4 FOR
SET PXSDTE=$ORDER(^XTMP("PXDELENC","FIXIND",PXPAT,PXSDTE))
if PXSDTE=""
QUIT
Begin DoDot:2
+5 FOR
SET PXENC=$ORDER(^XTMP("PXDELENC","FIXIND",PXPAT,PXSDTE,PXENC))
if PXENC=""
QUIT
Begin DoDot:3
+6 SET $PIECE(^DPT(PXPAT,"S",PXSDTE,0),"^",20)=""
+7 SET $PIECE(^DPT(PXPAT,"S",PXSDTE,0),"^",2)="NT"
+8 IF $PIECE($GET(^SCE(PXENC+1,0)),"^",6)=PXENC
SET PXSEC=PXENC+1
+9 SET DIK="^SCE("
SET DA=PXENC
DO ^DIK
+10 IF $GET(PXSEC)'=""
SET DIK="^SCE("
SET DA=PXSEC
DO ^DIK
+11 IF $DATA(^XTMP("PXDELENC","PXENC",PXPAT,PXSDTE,PXENC))
SET PXCOUNT=PXCOUNT-1
+12 KILL ^XTMP("PXDELENC","PXENC",PXPAT,PXSDTE,PXENC)
+13 KILL ^XTMP("PXDELENC","FIXIND",PXPAT,PXSDTE,PXENC)
+14 WRITE !!,?3,"Encounter: ",?12,$GET(PXENC)_" - "_$GET(PXPATNM),?45," Fixed!",!
+15 SET DA=PXPAT
DO FIXIHS
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET ^XTMP("PXDELENC","PXENC","PXCOUNT")=PXCOUNT
+17 if $DATA(DIRUT)
QUIT
+18 IF PXEXIST=1
Begin DoDot:1
+19 WRITE !!,"No more missing visits to correct for this patient!"
+20 DO WAIT^PXDELENC
End DoDot:1
NONE ;
+1 IF PXEXIST=0
Begin DoDot:1
+2 WRITE !!,"No missing visits found for this patient!"
+3 DO WAIT^PXDELENC
End DoDot:1
+4 KILL ^XTMP("PXDELENC","FIXIND")
+5 GOTO FIXIND
+6 QUIT
+1 WRITE !,?3,"Patient IEN - Name",?35,"Appt Date",?55,"Encounter"
+2 WRITE !,?3,"==================",?35,"=========",?55,"=========",!
+3 QUIT
FIXIHS ; Will fix the IHS Patient (9000001) file entries.
+1 NEW PX
+2 SET U="^"
+3 DO CHECK^PXXDPT
if '$TEST
QUIT
+4 SET PX=$PIECE($GET(^DPT(DA,0)),U,9)
+5 DO SETSSN^PXXDPT
+6 KILL DR,DIE,DA,PXDA
+7 QUIT
+8 ;
