ASDMERG ; IHS/ADC/PDW/ENM - -- sched patient merge ; [ 03/25/1999 11:48 AM ]
;;5.0;IHS SCHEDULING;;MAR 25, 1999
;
; ^SC(clinic,"S",appointment date/time,1,index,0)="patient^..."
; ^DPT(patient,"S",appointment date/time,0)="clinic^..."
;
; dfn=patient, c=clinic, i=index
; v=appointment date/time FM internal
;
;
I '$G(XDRMRG("FR")),'$G(XDRMRG("TO")) Q
N DFN,V,C,I,N,F
A ; -- update patient pointer in 44
S DFN=XDRMRG("FR"),V=0 F S V=$O(^DPT(DFN,"S",V)) Q:'V D
. S C=+$G(^DPT(DFN,"S",V,0)) Q:'C
. S I=0 F S I=$O(^SC(C,"S",V,1,I)) Q:'I D
.. S N=$G(^SC(C,"S",V,1,I,0)) Q:'N Q:+N'=DFN
.. S $P(^SC(C,"S",V,1,I,0),U)=XDRMRG("TO")
. K F S F="",I=0 F S I=$O(^SC(C,"S",V,1,I)) Q:'I D
.. S N=$G(^SC(C,"S",V,1,I,0)) Q:'N
.. K:$G(F(+N)) ^SC(C,"S",V,1,I) S F(+N)=1 Q
Q
;
44 ; -- check/cleanup 44
N DFN,V,C,I,N,F
S C=0 F S C=$O(^SC(C)) Q:'C D
. S V=0 F S V=$O(^SC(C,"S",V)) Q:'V D
.. K F S F="",I=0 F S I=$O(^SC(C,"S",V,1,I)) Q:'I D
... S N=$G(^SC(C,"S",V,1,I,0)) Q:'N
... S DFN=$P($G(^DPT(+N,0)),U,19)
... I DFN,$G(F(DFN)) K ^SC(C,"S",V,1,I) Q
... I $G(F(+N)) K ^SC(C,"S",V,1,I) Q
... S F(+N)=1 Q:'DFN S $P(^SC(C,"S",V,1,I,0),U)=DFN,F(DFN)=1
Q
;
2 ; -- if patient file node and no 44, set
N DFN,V,C,I,X,T,N,F
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN D
. S V=0 F S V=$O(^DPT(DFN,"S",V)) Q:'V D
.. S N=^DPT(DFN,"S",V,0) Q:'N S C=+N
.. S T="",(N,X,F,I)=0 F S I=$O(^SC(C,"S",V,1,I)) Q:'I Q:F D
... S X=I+1,N=$G(^SC(C,"S",V,1,I,0)),T=$P(N,U,2) I +N=DFN S F=I
.. Q:F S ^SC(C,"S",V,1,X,0)=DFN_U_T_U_U_"comp. gen."_U_U_DUZ_U_DT
Q
ASDMERG ; IHS/ADC/PDW/ENM - -- sched patient merge ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
+2 ;
+3 ; ^SC(clinic,"S",appointment date/time,1,index,0)="patient^..."
+4 ; ^DPT(patient,"S",appointment date/time,0)="clinic^..."
+5 ;
+6 ; dfn=patient, c=clinic, i=index
+7 ; v=appointment date/time FM internal
+8 ;
+9 ;
+10 IF '$GET(XDRMRG("FR"))
IF '$GET(XDRMRG("TO"))
QUIT
+11 NEW DFN,V,C,I,N,F
A ; -- update patient pointer in 44
+1 SET DFN=XDRMRG("FR")
SET V=0
FOR
SET V=$ORDER(^DPT(DFN,"S",V))
IF 'V
QUIT
Begin DoDot:1
+2 SET C=+$GET(^DPT(DFN,"S",V,0))
IF 'C
QUIT
+3 SET I=0
FOR
SET I=$ORDER(^SC(C,"S",V,1,I))
IF 'I
QUIT
Begin DoDot:2
+4 SET N=$GET(^SC(C,"S",V,1,I,0))
IF 'N
QUIT
IF +N'=DFN
QUIT
+5 SET $PIECE(^SC(C,"S",V,1,I,0),U)=XDRMRG("TO")
End DoDot:2
+6 KILL F
SET F=""
SET I=0
FOR
SET I=$ORDER(^SC(C,"S",V,1,I))
IF 'I
QUIT
Begin DoDot:2
+7 SET N=$GET(^SC(C,"S",V,1,I,0))
IF 'N
QUIT
+8 IF $GET(F(+N))
KILL ^SC(C,"S",V,1,I)
SET F(+N)=1
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
44 ; -- check/cleanup 44
+1 NEW DFN,V,C,I,N,F
+2 SET C=0
FOR
SET C=$ORDER(^SC(C))
IF 'C
QUIT
Begin DoDot:1
+3 SET V=0
FOR
SET V=$ORDER(^SC(C,"S",V))
IF 'V
QUIT
Begin DoDot:2
+4 KILL F
SET F=""
SET I=0
FOR
SET I=$ORDER(^SC(C,"S",V,1,I))
IF 'I
QUIT
Begin DoDot:3
+5 SET N=$GET(^SC(C,"S",V,1,I,0))
IF 'N
QUIT
+6 SET DFN=$PIECE($GET(^DPT(+N,0)),U,19)
+7 IF DFN
IF $GET(F(DFN))
KILL ^SC(C,"S",V,1,I)
QUIT
+8 IF $GET(F(+N))
KILL ^SC(C,"S",V,1,I)
QUIT
+9 SET F(+N)=1
IF 'DFN
QUIT
SET $PIECE(^SC(C,"S",V,1,I,0),U)=DFN
SET F(DFN)=1
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
2 ; -- if patient file node and no 44, set
+1 NEW DFN,V,C,I,X,T,N,F
+2 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+3 SET V=0
FOR
SET V=$ORDER(^DPT(DFN,"S",V))
IF 'V
QUIT
Begin DoDot:2
+4 SET N=^DPT(DFN,"S",V,0)
IF 'N
QUIT
SET C=+N
+5 SET T=""
SET (N,X,F,I)=0
FOR
SET I=$ORDER(^SC(C,"S",V,1,I))
IF 'I
QUIT
IF F
QUIT
Begin DoDot:3
+6 SET X=I+1
SET N=$GET(^SC(C,"S",V,1,I,0))
SET T=$PIECE(N,U,2)
IF +N=DFN
SET F=I
End DoDot:3
+7 IF F
QUIT
SET ^SC(C,"S",V,1,X,0)=DFN_U_T_U_U_"comp. gen."_U_U_DUZ_U_DT
End DoDot:2
End DoDot:1
+8 QUIT
