DPTDZFIX ; IHS/ANMC/LJF - RESET MERGE TO RUN AGAIN; [ 10/03/2001 8:13 AM ]
;1.0;PATIENT MERGE;
;
Q ;must use entry point
;
ASK ;EP; resets entry that merged but produced errors to ready state
I '$D(^XTMP("DPTDZFIX")) D
. D MSG("Need to run search for Lab pointers first.",1,0,0)
. D LRFIND ;need current list of LRDFN links
D MSG("Last search for lab pointers run on "_$$FMTE^XLFDT(+$G(^XTMP("DPTDZFIX",0))),2,1,0)
;
NEW DPTDN,DIC,DA,DR,DIQ
NEW DPTDN S DPTDN=$$READ("NO","Enter DUPLICATE RECORD #") Q:DPTDN<1
S DIC="^VA(15,",DA=DPTDN,DIQ(0)="CR" D EN^DIQ ;show entry
;
Q:'$$READ("Y","Okay to reset to run merge again")
;
I $P($G(^VA(15,DPTDN,0)),U,5)'=2 D Q
. D MSG("NOT MERGED! Reset not allowed.",1,1,0) D PAUSE
;
D RESET(DPTDN)
;
S DIC="^VA(15,",DA=DPTDN,DIQ(0)="CR" D EN^DIQ ;show updated entry
;
D MSG("WARNING: Please run merge right away as the FROM patient now",2,0,0)
D MSG("does NOT look merged to any patient lookup!!",1,0,0)
D PAUSE
Q
;
RESET(IEN) ; -- make changes to entry in files 15 and 2
Q:$P($G(^VA(15,IEN,0)),U,5)'=2 ;must have been merged before
;
;find FROM entry based on Merge Direction field
S X=$P(^VA(15,IEN,0),U,4),FROM=$P(^VA(15,IEN,0),U,X)
Q:FROM=""
;
;update merge status and remarks fields
S $P(^VA(15,IEN,0),U,5)=1 ;reset to ready state
S X=$P(^VA(15,IEN,0),U,8) ;date resolved on last merge attempt
S $P(^VA(15,IEN,1),U)="MERGE RUN ORIGINALLY ON "_$$FMTE^XLFDT(X)
;
;set LRDFN if needed
S X=$G(^XTMP("DPTDZFIX",FROM)) ;see if LRDFN exists in ^LR
I X,$P(^LR(X,0),U,3)=FROM S ^DPT(FROM,"LR")=X ;set LRDFN into DPT
;
; call IX1^DIK to re-index entry to fire xrefs
S DIK="^VA(15,",DA=IEN D IX1^DIK
;
; clean up zero node of DPT
S X=$$STRIP^XLFSTR($P(^DPT(+FROM,0),U),"*") ;strip * off of from pat
K ^DPT("B",$P(^DPT(+FROM,0),U),+FROM) ;kill xref with *
S $P(^DPT(+FROM,0),U)=X,^DPT("B",X,+FROM)="" ;reset name and xref
S $P(^DPT(+FROM,0),U,19)="" ;take merged to ien off
Q
;
LOOP ;EP; -- called to reset all past merges to ready status
NEW DPTDZN
S DPTDZN=0
F S DPTDZN=$O(^VA(15,DPTDZN)) Q:'DPTDZN D
. Q:$P($G(^VA(15,DPTDZN,0)),U,5)'=2 ;quit if not merged
. Q:$P($G(^VA(15,DPTDZN,1)),U)]"" ;remarks mean already rerun
. D RESET(DPTDZN)
. W !,DPTDZN
Q
;
PAUSE ;EP -- ask user to press return - no form feed
; called by option DPTD IHS MERGE VIEW
NEW DIR Q:IOST'["C-"
S DIR(0)="E",DIR("A")="Press ENTER to continue" D ^DIR
Q
;
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ; calls reader, returns response
NEW DIR,Y
S DIR(0)=TYPE
I $D(SCREEN) S DIR("S")=SCREEN
I $G(PROMPT)]"" S DIR("A")=PROMPT
I $G(DEFAULT)]"" S DIR("B")=DEFAULT
I $D(HELP) S DIR("?")=HELP
I $D(DIRA(1)) S Y=0 F S Y=$O(DIRA(Y)) Q:Y="" S DIR("A",Y)=DIRA(Y)
D ^DIR
Q Y
;
MSG(DATA,PRE,POST,BEEP) ; -- writes line to device
NEW I
I PRE>0 F I=1:1:PRE W !
W DATA
I POST>0 F I=1:1:POST W !
I $G(BEEP)>0 F I=1:1:BEEP W $C(7)
Q
;
LRFIND ;EP; -- finds all LRDFN entries in Lab without matching entries in DPT
D ^XBKVAR ;set min kernel variables
K ^XTMP("DPTDZFIX")
S ^XTMP("DPTDZFIX",0)=DT ;shows date last run
NEW LR,DFN
S LR=0 F S LR=$O(^LR(LR)) Q:LR'>0 D
. I '$D(^LR(LR,0)) Q ;no zero node
. Q:$P(^LR(LR,0),U,2)'=2 ;file must = 2 (^DPT)
. S DFN=+$P(^LR(LR,0),U,3) ;patient ien
. I '$D(^DPT(DFN,0)) Q ;no entry in DPT
. I '$D(^DPT(DFN,"LR")) S ^XTMP("DPTDZFIX",DFN)=LR ;set xtmp
Q
;
SCHED ;EP; -- find all merged patients with Scheduling data
; and set "S" nodes in DPT for those found
NEW CLINIC S U="^"
S CLINIC=0 F S CLINIC=$O(^SC(CLINIC)) Q:'CLINIC D
. S DATE=0 F S DATE=$O(^SC(CLINIC,"S",DATE)) Q:'DATE D
.. S N=0 F S N=$O(^SC(CLINIC,"S",DATE,1,N)) Q:'N D
... S PAT=+$G(^SC(CLINIC,"S",DATE,1,N,0)) Q:'PAT
... Q:$P($G(^DPT(PAT,0)),U,19)="" ;not merged from patient
... ; reset pointer in ^SC using merged to patient
... S $P(^SC(CLINIC,"S",DATE,1,N,0),U)=$P(^DPT(PAT,0),U,19)
... ;W !,PAT
Q
DPTDZFIX ; IHS/ANMC/LJF - RESET MERGE TO RUN AGAIN; [ 10/03/2001 8:13 AM ]
+1 ;1.0;PATIENT MERGE;
+2 ;
+3 ;must use entry point
QUIT
+4 ;
ASK ;EP; resets entry that merged but produced errors to ready state
+1 IF '$DATA(^XTMP("DPTDZFIX"))
Begin DoDot:1
+2 DO MSG("Need to run search for Lab pointers first.",1,0,0)
+3 ;need current list of LRDFN links
DO LRFIND
End DoDot:1
+4 DO MSG("Last search for lab pointers run on "_$$FMTE^XLFDT(+$GET(^XTMP("DPTDZFIX",0))),2,1,0)
+5 ;
+6 NEW DPTDN,DIC,DA,DR,DIQ
+7 NEW DPTDN
SET DPTDN=$$READ("NO","Enter DUPLICATE RECORD #")
IF DPTDN<1
QUIT
+8 ;show entry
SET DIC="^VA(15,"
SET DA=DPTDN
SET DIQ(0)="CR"
DO EN^DIQ
+9 ;
+10 IF '$$READ("Y","Okay to reset to run merge again")
QUIT
+11 ;
+12 IF $PIECE($GET(^VA(15,DPTDN,0)),U,5)'=2
Begin DoDot:1
+13 DO MSG("NOT MERGED! Reset not allowed.",1,1,0)
DO PAUSE
End DoDot:1
QUIT
+14 ;
+15 DO RESET(DPTDN)
+16 ;
+17 ;show updated entry
SET DIC="^VA(15,"
SET DA=DPTDN
SET DIQ(0)="CR"
DO EN^DIQ
+18 ;
+19 DO MSG("WARNING: Please run merge right away as the FROM patient now",2,0,0)
+20 DO MSG("does NOT look merged to any patient lookup!!",1,0,0)
+21 DO PAUSE
+22 QUIT
+23 ;
RESET(IEN) ; -- make changes to entry in files 15 and 2
+1 ;must have been merged before
IF $PIECE($GET(^VA(15,IEN,0)),U,5)'=2
QUIT
+2 ;
+3 ;find FROM entry based on Merge Direction field
+4 SET X=$PIECE(^VA(15,IEN,0),U,4)
SET FROM=$PIECE(^VA(15,IEN,0),U,X)
+5 IF FROM=""
QUIT
+6 ;
+7 ;update merge status and remarks fields
+8 ;reset to ready state
SET $PIECE(^VA(15,IEN,0),U,5)=1
+9 ;date resolved on last merge attempt
SET X=$PIECE(^VA(15,IEN,0),U,8)
+10 SET $PIECE(^VA(15,IEN,1),U)="MERGE RUN ORIGINALLY ON "_$$FMTE^XLFDT(X)
+11 ;
+12 ;set LRDFN if needed
+13 ;see if LRDFN exists in ^LR
SET X=$GET(^XTMP("DPTDZFIX",FROM))
+14 ;set LRDFN into DPT
IF X
IF $PIECE(^LR(X,0),U,3)=FROM
SET ^DPT(FROM,"LR")=X
+15 ;
+16 ; call IX1^DIK to re-index entry to fire xrefs
+17 SET DIK="^VA(15,"
SET DA=IEN
DO IX1^DIK
+18 ;
+19 ; clean up zero node of DPT
+20 ;strip * off of from pat
SET X=$$STRIP^XLFSTR($PIECE(^DPT(+FROM,0),U),"*")
+21 ;kill xref with *
KILL ^DPT("B",$PIECE(^DPT(+FROM,0),U),+FROM)
+22 ;reset name and xref
SET $PIECE(^DPT(+FROM,0),U)=X
SET ^DPT("B",X,+FROM)=""
+23 ;take merged to ien off
SET $PIECE(^DPT(+FROM,0),U,19)=""
+24 QUIT
+25 ;
LOOP ;EP; -- called to reset all past merges to ready status
+1 NEW DPTDZN
+2 SET DPTDZN=0
+3 FOR
SET DPTDZN=$ORDER(^VA(15,DPTDZN))
IF 'DPTDZN
QUIT
Begin DoDot:1
+4 ;quit if not merged
IF $PIECE($GET(^VA(15,DPTDZN,0)),U,5)'=2
QUIT
+5 ;remarks mean already rerun
IF $PIECE($GET(^VA(15,DPTDZN,1)),U)]""
QUIT
+6 DO RESET(DPTDZN)
+7 WRITE !,DPTDZN
End DoDot:1
+8 QUIT
+9 ;
PAUSE ;EP -- ask user to press return - no form feed
+1 ; called by option DPTD IHS MERGE VIEW
+2 NEW DIR
IF IOST'["C-"
QUIT
+3 SET DIR(0)="E"
SET DIR("A")="Press ENTER to continue"
DO ^DIR
+4 QUIT
+5 ;
READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ; calls reader, returns response
+1 NEW DIR,Y
+2 SET DIR(0)=TYPE
+3 IF $DATA(SCREEN)
SET DIR("S")=SCREEN
+4 IF $GET(PROMPT)]""
SET DIR("A")=PROMPT
+5 IF $GET(DEFAULT)]""
SET DIR("B")=DEFAULT
+6 IF $DATA(HELP)
SET DIR("?")=HELP
+7 IF $DATA(DIRA(1))
SET Y=0
FOR
SET Y=$ORDER(DIRA(Y))
IF Y=""
QUIT
SET DIR("A",Y)=DIRA(Y)
+8 DO ^DIR
+9 QUIT Y
+10 ;
MSG(DATA,PRE,POST,BEEP) ; -- writes line to device
+1 NEW I
+2 IF PRE>0
FOR I=1:1:PRE
WRITE !
+3 WRITE DATA
+4 IF POST>0
FOR I=1:1:POST
WRITE !
+5 IF $GET(BEEP)>0
FOR I=1:1:BEEP
WRITE $CHAR(7)
+6 QUIT
+7 ;
LRFIND ;EP; -- finds all LRDFN entries in Lab without matching entries in DPT
+1 ;set min kernel variables
DO ^XBKVAR
+2 KILL ^XTMP("DPTDZFIX")
+3 ;shows date last run
SET ^XTMP("DPTDZFIX",0)=DT
+4 NEW LR,DFN
+5 SET LR=0
FOR
SET LR=$ORDER(^LR(LR))
IF LR'>0
QUIT
Begin DoDot:1
+6 ;no zero node
IF '$DATA(^LR(LR,0))
QUIT
+7 ;file must = 2 (^DPT)
IF $PIECE(^LR(LR,0),U,2)'=2
QUIT
+8 ;patient ien
SET DFN=+$PIECE(^LR(LR,0),U,3)
+9 ;no entry in DPT
IF '$DATA(^DPT(DFN,0))
QUIT
+10 ;set xtmp
IF '$DATA(^DPT(DFN,"LR"))
SET ^XTMP("DPTDZFIX",DFN)=LR
End DoDot:1
+11 QUIT
+12 ;
SCHED ;EP; -- find all merged patients with Scheduling data
+1 ; and set "S" nodes in DPT for those found
+2 NEW CLINIC
SET U="^"
+3 SET CLINIC=0
FOR
SET CLINIC=$ORDER(^SC(CLINIC))
IF 'CLINIC
QUIT
Begin DoDot:1
+4 SET DATE=0
FOR
SET DATE=$ORDER(^SC(CLINIC,"S",DATE))
IF 'DATE
QUIT
Begin DoDot:2
+5 SET N=0
FOR
SET N=$ORDER(^SC(CLINIC,"S",DATE,1,N))
IF 'N
QUIT
Begin DoDot:3
+6 SET PAT=+$GET(^SC(CLINIC,"S",DATE,1,N,0))
IF 'PAT
QUIT
+7 ;not merged from patient
IF $PIECE($GET(^DPT(PAT,0)),U,19)=""
QUIT
+8 ; reset pointer in ^SC using merged to patient
+9 SET $PIECE(^SC(CLINIC,"S",DATE,1,N,0),U)=$PIECE(^DPT(PAT,0),U,19)
+10 ;W !,PAT
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
