AUPNPCTR ; IHS/CMI/LAB - XREF TRIGGER FROM #1117 (RESIDENCE COMMUNITY PT) TO LAST PREVIOUS COMMUNITY 24-MAY-1993 ; [ 10/03/2007 8:57 AM ]
;;99.1;IHS DICTIONARIES (PATIENT);**6,9,10,18,19**;JUN 13, 2003;Build 9
S ;ENTRY POINT FOR SET TRIGGERS
S DFN=DA(1),AUPN51DA=DA NEW (DFN,DT,DUZ,U,AUPN51DA)
D LD I AUPN5LD,AUPN5LD=AUPN51DA
E G END ; quit if date being edited is not the last date
D SET G END
;-------------------------------------------------
K ;ENTRY POINT FOR KILL TRIGGER
S DFN=DA(1),AUPN51DA=DA NEW (DFN,DT,DUZ,U,AUPN51DA)
D LD I AUPN5LD,AUPN5LD=AUPN51DA
E G END ;exit if day being deleted is not the last date
; find next to last date
S (AUPN5,AUPN5NLD)=0 I ($D(^AUPNPAT(DFN,51))>1) F S AUPN5=$O(^AUPNPAT(DFN,51,AUPN5)) Q:'AUPN5 Q:AUPN5=AUPN5LD S AUPN5NLD=AUPN5
S AUPN5LD=AUPN5NLD
D SET G END
;
;------------------------------------------------------------
LD ; find last date
S (AUPN5,AUPN5LD)=0
I ($D(^AUPNPAT(DFN,51))>1) F S AUPN5=$O(^AUPNPAT(DFN,51,AUPN5)) Q:'AUPN5 S AUPN5LD=AUPN5
Q
;-------------------------------------------------
SET ; Set Current Community , Current Residence PTR, Current Residence Date ; IHS/PAO/TMJ Fix of Subscript and DIE Call
I AUPN5LD D I AUPNCC>0,AUPNCCN]""
. S AUPNCC=$P($G(^AUPNPAT(DFN,51,AUPN5LD,0)),"^",3)
. Q:AUPNCC=""
. S AUPNCCN=$P($G(^AUTTCOM(AUPNCC,0)),U) ; pickup Current Community Pointer and name
E S AUPNCC="@",AUPNCCN="@"
S DIE="^AUPNPAT(",DA=DFN,DR="1118///"_AUPNCCN D ^DIE
K AUPNTEMP("MFI",$J) S DR="1117///"_$S(AUPNCC="@":"",1:"`")_AUPNCC D ^DIE K AUPNTEMP("MFI",$J)
S Y="@" I AUPN5LD S Y=AUPN5LD D DD^%DT
S DR="1113///"_Y D ^DIE K AUPNTEMP("MFI",$J)
Q
;------------------------------------------------------------
END ;
EXIT ; all entry points NEW (DFN,DUZ,DT,U) and exit here
K AUPN51DA
Q
;------------------------------------------------------------
;------------------------------------------------------------
MFI ;ENTRY POINT FOR MFI
Q:$G(XDRGID) ;IHS/OIT/LJF 02/28/2008 PATCH 19 skip if in Patient Merge
S DFN=DA NEW (DFN,DT,DUZ,U,AUPN51DA,AUPNDOB,AUPNDOD,AUPNTEMP)
I $D(AUPNTEMP("MFI",$J,DFN,1117)),$D(AUPNTEMP("MFI",$J,DFN,1113))
E Q ; wait for both fields to be set by MFI
D SETMFI K AUPNTEMP("MFI",$J,DFN)
D LD D SET
G END
;
;--------------------------------------------------
SETMFI ;
S:'$D(^AUPNPAT(DFN,51,0)) ^AUPNPAT(DFN,51,0)="^9000001.51D^^"
S AUPNCC=$P(^AUPNPAT(DFN,11),U,17),AUPNDT=$P(^AUPNPAT(DFN,11),U,13)
I $D(^AUPNPAT(DFN,51,AUPNDT,0)),$P(^(0),U)=AUPNDT,$P(^(0),U,3)=AUPNCC Q ; if node matches do not reset
S AUPNX=0 F S AUPNX=$O(^AUPNPAT(DFN,51,AUPNX)) Q:'AUPNX S AUPNLPC=$P(^AUPNPAT(DFN,51,AUPNX,0),U,3),AUPNX1=AUPNX
I $D(AUPNLPC),AUPNLPC=AUPNCC D DELCC
S Y=AUPNDT D DD^%DT S X=Y,DIC="^AUPNPAT("_DFN_",51,",DIC(0)="ML",DA(1)=DFN D ^DIC K DIC,DR Q:'+Y
S DA=AUPNDT,DA(1)=DFN,DIE="^AUPNPAT("_DFN_",51,",DR=".03////"_AUPNCC
I $P(^AUPNPAT(DFN,51,DA,0),U,2)="" S DR=DR_";.02////"_DT
D ^DIE
Q
;
DELCC ; Delete Last Previous community multiple
S DA(1)=DFN,DA=AUPNX1,DIK="^AUPNPAT("_DA(1)_",51,"
D ^DIK K DA,DIK
Q
;
LASTEM(PAT) ;EP - called from trigger on previous email field
NEW A,B,C
K B
S C=""
S A=0 F S A=$O(^AUPNPAT(PAT,82,A)) Q:A'=+A D
.Q:$P(^AUPNPAT(PAT,82,A,0),U,1)="" ;no date yet
.S B(9999999-$P(^AUPNPAT(PAT,82,A,0),U,1))=$P(^AUPNPAT(PAT,82,A,0),U,2)
.Q
S C=$O(B(0))
I C Q B(C)
Q ""
;
LASTADDR(P,V) ;EP - called to update .111 in file 2
NEW A,B,C
K B
S A=0,C="" F S A=$O(^AUPNPAT(P,83,A)) Q:A'=+A D
.Q:$P(^AUPNPAT(P,83,A,0),U,1)="" ;no date yet
.S B(9999999-$P(^AUPNPAT(P,83,A,0),U,1))=$P(^AUPNPAT(P,83,A,0),U,V)
.Q
S C=$O(B(0))
I C Q B(C)
Q ""
;
AUPNPCTR ; IHS/CMI/LAB - XREF TRIGGER FROM #1117 (RESIDENCE COMMUNITY PT) TO LAST PREVIOUS COMMUNITY 24-MAY-1993 ; [ 10/03/2007 8:57 AM ]
+1 ;;99.1;IHS DICTIONARIES (PATIENT);**6,9,10,18,19**;JUN 13, 2003;Build 9
S ;ENTRY POINT FOR SET TRIGGERS
+1 SET DFN=DA(1)
SET AUPN51DA=DA
NEW (DFN,DT,DUZ,U,AUPN51DA)
+2 DO LD
IF AUPN5LD
IF AUPN5LD=AUPN51DA
+3 ; quit if date being edited is not the last date
IF '$TEST
GOTO END
+4 DO SET
GOTO END
+5 ;-------------------------------------------------
K ;ENTRY POINT FOR KILL TRIGGER
+1 SET DFN=DA(1)
SET AUPN51DA=DA
NEW (DFN,DT,DUZ,U,AUPN51DA)
+2 DO LD
IF AUPN5LD
IF AUPN5LD=AUPN51DA
+3 ;exit if day being deleted is not the last date
IF '$TEST
GOTO END
+4 ; find next to last date
+5 SET (AUPN5,AUPN5NLD)=0
IF ($DATA(^AUPNPAT(DFN,51))>1)
FOR
SET AUPN5=$ORDER(^AUPNPAT(DFN,51,AUPN5))
IF 'AUPN5
QUIT
IF AUPN5=AUPN5LD
QUIT
SET AUPN5NLD=AUPN5
+6 SET AUPN5LD=AUPN5NLD
+7 DO SET
GOTO END
+8 ;
+9 ;------------------------------------------------------------
LD ; find last date
+1 SET (AUPN5,AUPN5LD)=0
+2 IF ($DATA(^AUPNPAT(DFN,51))>1)
FOR
SET AUPN5=$ORDER(^AUPNPAT(DFN,51,AUPN5))
IF 'AUPN5
QUIT
SET AUPN5LD=AUPN5
+3 QUIT
+4 ;-------------------------------------------------
SET ; Set Current Community , Current Residence PTR, Current Residence Date ; IHS/PAO/TMJ Fix of Subscript and DIE Call
+1 IF AUPN5LD
Begin DoDot:1
+2 SET AUPNCC=$PIECE($GET(^AUPNPAT(DFN,51,AUPN5LD,0)),"^",3)
+3 IF AUPNCC=""
QUIT
+4 ; pickup Current Community Pointer and name
SET AUPNCCN=$PIECE($GET(^AUTTCOM(AUPNCC,0)),U)
End DoDot:1
IF AUPNCC>0
IF AUPNCCN]""
+5 IF '$TEST
SET AUPNCC="@"
SET AUPNCCN="@"
+6 SET DIE="^AUPNPAT("
SET DA=DFN
SET DR="1118///"_AUPNCCN
DO ^DIE
+7 KILL AUPNTEMP("MFI",$JOB)
SET DR="1117///"_$SELECT(AUPNCC="@":"",1:"`")_AUPNCC
DO ^DIE
KILL AUPNTEMP("MFI",$JOB)
+8 SET Y="@"
IF AUPN5LD
SET Y=AUPN5LD
DO DD^%DT
+9 SET DR="1113///"_Y
DO ^DIE
KILL AUPNTEMP("MFI",$JOB)
+10 QUIT
+11 ;------------------------------------------------------------
END ;
EXIT ; all entry points NEW (DFN,DUZ,DT,U) and exit here
+1 KILL AUPN51DA
+2 QUIT
+3 ;------------------------------------------------------------
+4 ;------------------------------------------------------------
MFI ;ENTRY POINT FOR MFI
+1 ;IHS/OIT/LJF 02/28/2008 PATCH 19 skip if in Patient Merge
IF $GET(XDRGID)
QUIT
+2 SET DFN=DA
NEW (DFN,DT,DUZ,U,AUPN51DA,AUPNDOB,AUPNDOD,AUPNTEMP)
+3 IF $DATA(AUPNTEMP("MFI",$JOB,DFN,1117))
IF $DATA(AUPNTEMP("MFI",$JOB,DFN,1113))
+4 ; wait for both fields to be set by MFI
IF '$TEST
QUIT
+5 DO SETMFI
KILL AUPNTEMP("MFI",$JOB,DFN)
+6 DO LD
DO SET
+7 GOTO END
+8 ;
+9 ;--------------------------------------------------
SETMFI ;
+1 IF '$DATA(^AUPNPAT(DFN,51,0))
SET ^AUPNPAT(DFN,51,0)="^9000001.51D^^"
+2 SET AUPNCC=$PIECE(^AUPNPAT(DFN,11),U,17)
SET AUPNDT=$PIECE(^AUPNPAT(DFN,11),U,13)
+3 ; if node matches do not reset
IF $DATA(^AUPNPAT(DFN,51,AUPNDT,0))
IF $PIECE(^(0),U)=AUPNDT
IF $PIECE(^(0),U,3)=AUPNCC
QUIT
+4 SET AUPNX=0
FOR
SET AUPNX=$ORDER(^AUPNPAT(DFN,51,AUPNX))
IF 'AUPNX
QUIT
SET AUPNLPC=$PIECE(^AUPNPAT(DFN,51,AUPNX,0),U,3)
SET AUPNX1=AUPNX
+5 IF $DATA(AUPNLPC)
IF AUPNLPC=AUPNCC
DO DELCC
+6 SET Y=AUPNDT
DO DD^%DT
SET X=Y
SET DIC="^AUPNPAT("_DFN_",51,"
SET DIC(0)="ML"
SET DA(1)=DFN
DO ^DIC
KILL DIC,DR
IF '+Y
QUIT
+7 SET DA=AUPNDT
SET DA(1)=DFN
SET DIE="^AUPNPAT("_DFN_",51,"
SET DR=".03////"_AUPNCC
+8 IF $PIECE(^AUPNPAT(DFN,51,DA,0),U,2)=""
SET DR=DR_";.02////"_DT
+9 DO ^DIE
+10 QUIT
+11 ;
DELCC ; Delete Last Previous community multiple
+1 SET DA(1)=DFN
SET DA=AUPNX1
SET DIK="^AUPNPAT("_DA(1)_",51,"
+2 DO ^DIK
KILL DA,DIK
+3 QUIT
+4 ;
LASTEM(PAT) ;EP - called from trigger on previous email field
+1 NEW A,B,C
+2 KILL B
+3 SET C=""
+4 SET A=0
FOR
SET A=$ORDER(^AUPNPAT(PAT,82,A))
IF A'=+A
QUIT
Begin DoDot:1
+5 ;no date yet
IF $PIECE(^AUPNPAT(PAT,82,A,0),U,1)=""
QUIT
+6 SET B(9999999-$PIECE(^AUPNPAT(PAT,82,A,0),U,1))=$PIECE(^AUPNPAT(PAT,82,A,0),U,2)
+7 QUIT
End DoDot:1
+8 SET C=$ORDER(B(0))
+9 IF C
QUIT B(C)
+10 QUIT ""
+11 ;
LASTADDR(P,V) ;EP - called to update .111 in file 2
+1 NEW A,B,C
+2 KILL B
+3 SET A=0
SET C=""
FOR
SET A=$ORDER(^AUPNPAT(P,83,A))
IF A'=+A
QUIT
Begin DoDot:1
+4 ;no date yet
IF $PIECE(^AUPNPAT(P,83,A,0),U,1)=""
QUIT
+5 SET B(9999999-$PIECE(^AUPNPAT(P,83,A,0),U,1))=$PIECE(^AUPNPAT(P,83,A,0),U,V)
+6 QUIT
End DoDot:1
+7 SET C=$ORDER(B(0))
+8 IF C
QUIT B(C)
+9 QUIT ""
+10 ;
