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

AUPNPCTR.m

Go to the documentation of this file.
  1. 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
  1. S ;ENTRY POINT FOR SET TRIGGERS
  1. S DFN=DA(1),AUPN51DA=DA NEW (DFN,DT,DUZ,U,AUPN51DA)
  1. D LD I AUPN5LD,AUPN5LD=AUPN51DA
  1. E G END ; quit if date being edited is not the last date
  1. D SET G END
  1. ;-------------------------------------------------
  1. K ;ENTRY POINT FOR KILL TRIGGER
  1. S DFN=DA(1),AUPN51DA=DA NEW (DFN,DT,DUZ,U,AUPN51DA)
  1. D LD I AUPN5LD,AUPN5LD=AUPN51DA
  1. E G END ;exit if day being deleted is not the last date
  1. ; find next to last date
  1. 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
  1. S AUPN5LD=AUPN5NLD
  1. D SET G END
  1. ;
  1. ;------------------------------------------------------------
  1. LD ; find last date
  1. S (AUPN5,AUPN5LD)=0
  1. I ($D(^AUPNPAT(DFN,51))>1) F S AUPN5=$O(^AUPNPAT(DFN,51,AUPN5)) Q:'AUPN5 S AUPN5LD=AUPN5
  1. Q
  1. ;-------------------------------------------------
  1. SET ; Set Current Community , Current Residence PTR, Current Residence Date ; IHS/PAO/TMJ Fix of Subscript and DIE Call
  1. I AUPN5LD D I AUPNCC>0,AUPNCCN]""
  1. . S AUPNCC=$P($G(^AUPNPAT(DFN,51,AUPN5LD,0)),"^",3)
  1. . Q:AUPNCC=""
  1. . S AUPNCCN=$P($G(^AUTTCOM(AUPNCC,0)),U) ; pickup Current Community Pointer and name
  1. E S AUPNCC="@",AUPNCCN="@"
  1. S DIE="^AUPNPAT(",DA=DFN,DR="1118///"_AUPNCCN D ^DIE
  1. K AUPNTEMP("MFI",$J) S DR="1117///"_$S(AUPNCC="@":"",1:"`")_AUPNCC D ^DIE K AUPNTEMP("MFI",$J)
  1. S Y="@" I AUPN5LD S Y=AUPN5LD D DD^%DT
  1. S DR="1113///"_Y D ^DIE K AUPNTEMP("MFI",$J)
  1. Q
  1. ;------------------------------------------------------------
  1. END ;
  1. EXIT ; all entry points NEW (DFN,DUZ,DT,U) and exit here
  1. K AUPN51DA
  1. Q
  1. ;------------------------------------------------------------
  1. ;------------------------------------------------------------
  1. MFI ;ENTRY POINT FOR MFI
  1. Q:$G(XDRGID) ;IHS/OIT/LJF 02/28/2008 PATCH 19 skip if in Patient Merge
  1. S DFN=DA NEW (DFN,DT,DUZ,U,AUPN51DA,AUPNDOB,AUPNDOD,AUPNTEMP)
  1. I $D(AUPNTEMP("MFI",$J,DFN,1117)),$D(AUPNTEMP("MFI",$J,DFN,1113))
  1. E Q ; wait for both fields to be set by MFI
  1. D SETMFI K AUPNTEMP("MFI",$J,DFN)
  1. D LD D SET
  1. G END
  1. ;
  1. ;--------------------------------------------------
  1. SETMFI ;
  1. S:'$D(^AUPNPAT(DFN,51,0)) ^AUPNPAT(DFN,51,0)="^9000001.51D^^"
  1. S AUPNCC=$P(^AUPNPAT(DFN,11),U,17),AUPNDT=$P(^AUPNPAT(DFN,11),U,13)
  1. I $D(^AUPNPAT(DFN,51,AUPNDT,0)),$P(^(0),U)=AUPNDT,$P(^(0),U,3)=AUPNCC Q ; if node matches do not reset
  1. 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
  1. I $D(AUPNLPC),AUPNLPC=AUPNCC D DELCC
  1. 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
  1. S DA=AUPNDT,DA(1)=DFN,DIE="^AUPNPAT("_DFN_",51,",DR=".03////"_AUPNCC
  1. I $P(^AUPNPAT(DFN,51,DA,0),U,2)="" S DR=DR_";.02////"_DT
  1. D ^DIE
  1. Q
  1. ;
  1. DELCC ; Delete Last Previous community multiple
  1. S DA(1)=DFN,DA=AUPNX1,DIK="^AUPNPAT("_DA(1)_",51,"
  1. D ^DIK K DA,DIK
  1. Q
  1. ;
  1. LASTEM(PAT) ;EP - called from trigger on previous email field
  1. NEW A,B,C
  1. K B
  1. S C=""
  1. S A=0 F S A=$O(^AUPNPAT(PAT,82,A)) Q:A'=+A D
  1. .Q:$P(^AUPNPAT(PAT,82,A,0),U,1)="" ;no date yet
  1. .S B(9999999-$P(^AUPNPAT(PAT,82,A,0),U,1))=$P(^AUPNPAT(PAT,82,A,0),U,2)
  1. .Q
  1. S C=$O(B(0))
  1. I C Q B(C)
  1. Q ""
  1. ;
  1. LASTADDR(P,V) ;EP - called to update .111 in file 2
  1. NEW A,B,C
  1. K B
  1. S A=0,C="" F S A=$O(^AUPNPAT(P,83,A)) Q:A'=+A D
  1. .Q:$P(^AUPNPAT(P,83,A,0),U,1)="" ;no date yet
  1. .S B(9999999-$P(^AUPNPAT(P,83,A,0),U,1))=$P(^AUPNPAT(P,83,A,0),U,V)
  1. .Q
  1. S C=$O(B(0))
  1. I C Q B(C)
  1. Q ""
  1. ;