Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DPTDZFIX

DPTDZFIX.m

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