ACHSMERG ; IHS/ITSC/TPF/PMF - CHS PATIENT MERGE INTERFACE ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**20**;JUN 11, 2001
;
; This entire routine is in support
; of the patient merge development and testing.
;
; XDRMRG("FR") contains DFN of FROM pt (one being merged away)
; XDRMRG("TO") contains DFN of TO pt (the one being kept)
;
;ACHS*3.1*20 IHS.OIT.FCJ 7-28-11 ADDED NXT LINE FOR CALL FROM MERGE ROUTINES
EN(XDRMRG) ;EP
;
Q:'$D(XDRMRG("FR"))
Q:'$D(XDRMRG("TO"))
;
; S XDRMRG("FR")=1062,XDRMRG("TO")=1064 ; *** FOR TESTING, ONLY
; S XDRMRG("FR")=1064,XDRMRG("TO")=1062 ; *** FOR TESTING, ONLY
;
N L,D,T
;
; L = Location
; D = Document IEN
; T = Transaction IEN
;
; ^ACHSF(DA(1),"PB",+X,DA,1)
; ^ACHSF("AC",$E(X,1,30),DA(2),DA(1),DA)
; ^ACHSF(DA(2),"EOBP",+X,DA(1),DA,9999999-%)
; The "PB" x-ref is more reliable. The "AC" is only set at
; final pay.
; One entire document is merged, at once, rather than use the "PB"
; for the Document record, then the "AC" for the transaction
; records, to minimize the possibility of errors.
;
S L=0
;
F S L=$O(^ACHSF(L)) Q:'L S D=0 F S D=$O(^ACHSF(L,"PB",XDRMRG("FR"),D)) Q:'D D
.K ^ACHSF(L,"PB",XDRMRG("FR"),D)
.Q:'$D(^ACHSF(L,"D",D,0))
.S $P(^ACHSF(L,"D",D,0),U,22)=XDRMRG("TO")
.S ^ACHSF(L,"PB",XDRMRG("TO"),D,1)=""
.S T=0
.F S T=$O(^ACHSF(L,"D",D,"T",T)) Q:'T D
..K ^ACHSF("AC",XDRMRG("FR"),L,D,T)
..K ^ACHSF(L,"EOBP",XDRMRG("FR"),D,T)
..S $P(^ACHSF(L,"D",D,"T",T,0),U,3)=XDRMRG("TO")
..S ^ACHSF("AC",XDRMRG("TO"),L,D,T)=""
..S %=$P(^ACHSF(L,"D",D,"T",T,0),U,13)
..I % S ^ACHSF(L,"EOBP",XDRMRG("TO"),D,T,9999999-%)=""
..Q
.Q
;
;
;
; L = Patient Name
; D = Denial IEN
;
; ^ACHSDEN("C",$P(^DPT(X,0),U,1),DA)
;
S L=$P(^DPT(XDRMRG("FR"),0),U),D=0
;
F S D=$O(^ACHSDEN("C",L,D)) Q:'D I $P(^ACHSDEN(D,0),U,4)="Y" D
.K ^ACHSDEN("C",L,D)
.S $P(^ACHSDEN(D,0),U,5)=XDRMRG("TO")
.S ^ACHSDEN("C",$P(^DPT(XDRMRG("TO"),0),U),D)=""
.Q
;
Q
;
;
FR ;EP - From PACKAGE file, to determine if FR pt has data for pt merge.
Q:'$D(XDRMRG("FR"))
N L
;
; L = Location or Pt Name
;
S L=0
;
F S L=$O(^ACHSF(L)) Q:'L I $O(^ACHSF(L,"PB",XDRMRG("FR"),0)) S XDRZ=1 Q
;
S L=$P(^DPT(XDRMRG("FR"),0),U),D=0
;
F S D=$O(^ACHSDEN("C",L,D)) Q:'D I $P(^ACHSDEN(D,0),U,4)="Y" S XDRZ=1 Q
;
Q
;
ACHSMERG ; IHS/ITSC/TPF/PMF - CHS PATIENT MERGE INTERFACE ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**20**;JUN 11, 2001
+2 ;
+3 ; This entire routine is in support
+4 ; of the patient merge development and testing.
+5 ;
+6 ; XDRMRG("FR") contains DFN of FROM pt (one being merged away)
+7 ; XDRMRG("TO") contains DFN of TO pt (the one being kept)
+8 ;
+9 ;ACHS*3.1*20 IHS.OIT.FCJ 7-28-11 ADDED NXT LINE FOR CALL FROM MERGE ROUTINES
EN(XDRMRG) ;EP
+1 ;
+2 IF '$DATA(XDRMRG("FR"))
QUIT
+3 IF '$DATA(XDRMRG("TO"))
QUIT
+4 ;
+5 ; S XDRMRG("FR")=1062,XDRMRG("TO")=1064 ; *** FOR TESTING, ONLY
+6 ; S XDRMRG("FR")=1064,XDRMRG("TO")=1062 ; *** FOR TESTING, ONLY
+7 ;
+8 NEW L,D,T
+9 ;
+10 ; L = Location
+11 ; D = Document IEN
+12 ; T = Transaction IEN
+13 ;
+14 ; ^ACHSF(DA(1),"PB",+X,DA,1)
+15 ; ^ACHSF("AC",$E(X,1,30),DA(2),DA(1),DA)
+16 ; ^ACHSF(DA(2),"EOBP",+X,DA(1),DA,9999999-%)
+17 ; The "PB" x-ref is more reliable. The "AC" is only set at
+18 ; final pay.
+19 ; One entire document is merged, at once, rather than use the "PB"
+20 ; for the Document record, then the "AC" for the transaction
+21 ; records, to minimize the possibility of errors.
+22 ;
+23 SET L=0
+24 ;
+25 FOR
SET L=$ORDER(^ACHSF(L))
IF 'L
QUIT
SET D=0
FOR
SET D=$ORDER(^ACHSF(L,"PB",XDRMRG("FR"),D))
IF 'D
QUIT
Begin DoDot:1
+26 KILL ^ACHSF(L,"PB",XDRMRG("FR"),D)
+27 IF '$DATA(^ACHSF(L,"D",D,0))
QUIT
+28 SET $PIECE(^ACHSF(L,"D",D,0),U,22)=XDRMRG("TO")
+29 SET ^ACHSF(L,"PB",XDRMRG("TO"),D,1)=""
+30 SET T=0
+31 FOR
SET T=$ORDER(^ACHSF(L,"D",D,"T",T))
IF 'T
QUIT
Begin DoDot:2
+32 KILL ^ACHSF("AC",XDRMRG("FR"),L,D,T)
+33 KILL ^ACHSF(L,"EOBP",XDRMRG("FR"),D,T)
+34 SET $PIECE(^ACHSF(L,"D",D,"T",T,0),U,3)=XDRMRG("TO")
+35 SET ^ACHSF("AC",XDRMRG("TO"),L,D,T)=""
+36 SET %=$PIECE(^ACHSF(L,"D",D,"T",T,0),U,13)
+37 IF %
SET ^ACHSF(L,"EOBP",XDRMRG("TO"),D,T,9999999-%)=""
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 ;
+41 ;
+42 ;
+43 ; L = Patient Name
+44 ; D = Denial IEN
+45 ;
+46 ; ^ACHSDEN("C",$P(^DPT(X,0),U,1),DA)
+47 ;
+48 SET L=$PIECE(^DPT(XDRMRG("FR"),0),U)
SET D=0
+49 ;
+50 FOR
SET D=$ORDER(^ACHSDEN("C",L,D))
IF 'D
QUIT
IF $PIECE(^ACHSDEN(D,0),U,4)="Y"
Begin DoDot:1
+51 KILL ^ACHSDEN("C",L,D)
+52 SET $PIECE(^ACHSDEN(D,0),U,5)=XDRMRG("TO")
+53 SET ^ACHSDEN("C",$PIECE(^DPT(XDRMRG("TO"),0),U),D)=""
+54 QUIT
End DoDot:1
+55 ;
+56 QUIT
+57 ;
+58 ;
FR ;EP - From PACKAGE file, to determine if FR pt has data for pt merge.
+1 IF '$DATA(XDRMRG("FR"))
QUIT
+2 NEW L
+3 ;
+4 ; L = Location or Pt Name
+5 ;
+6 SET L=0
+7 ;
+8 FOR
SET L=$ORDER(^ACHSF(L))
IF 'L
QUIT
IF $ORDER(^ACHSF(L,"PB",XDRMRG("FR"),0))
SET XDRZ=1
QUIT
+9 ;
+10 SET L=$PIECE(^DPT(XDRMRG("FR"),0),U)
SET D=0
+11 ;
+12 FOR
SET D=$ORDER(^ACHSDEN("C",L,D))
IF 'D
QUIT
IF $PIECE(^ACHSDEN(D,0),U,4)="Y"
SET XDRZ=1
QUIT
+13 ;
+14 QUIT
+15 ;
