VAFCTFU ;ALB/JLU-UTILITIES FOR THE TREATING FACILITY FILE 391.91 ; 1/15/10 5:00pm
;;5.3;PIMS;**149,240,261,255,316,392,440,428,474,520,697,1015,1016**;JUN 30, 2012;Build 20
;
;Reference to EXC^RGHLLOG and STOP^RGHLLOG supported by IA #2796
;Reference to $$UPDATE^ MPIFAPI supported by IA #2706
;
;CHKSUB & GETSCN line tags removed, patch DG*5.3*697
;Subscriptions are no longer used and errors are being
;generated when attempting to add a subscription.
;
FILETF(PAT,INST) ;programmer entry point.
;INPUT PAT - This is the patient's ICN
; INST - This is the IEN of the institution or Treating Facility
;it also contains the date of treatment in FM format. It is to be
;stored in an array structure to allow for multiple treating
;facilities.
; EX. X(1)=500^2960101
; x(2)=425^2960202
;
;OUTPUT 0 (ZERO) If no errors
; 1^error description if there was an error.
;
N PDFN,LP,VAFCER,X
S VAFCER=0
I '$G(PAT)!('$D(INST)) S VAFCER="1^Parameter missing." G FILETFQ
I $D(@INST)<10 S VAFCER="1^Institution array not populated." G FILETFQ
S X="MPIF001" X ^%ZOSF("TEST") I '$T G FILETFQ
S PDFN=$$GETDFN^MPIF001(PAT)
I PDFN<0 S VAFCER="1^No patient DFN." G FILETFQ
N FSTRG
F LP=0:0 S LP=$O(@INST@(LP)) Q:'LP D FILE(PDFN,@INST@(LP))
;
FILETFQ Q VAFCER
;
; both the SET & QUERYTF subroutines have been moved to VAFCTFU1 as
; the result of DG*5.3*261 *261 gjc@120899
;
FILE(PDFN,FSTRG,TICN,VAFCSLT,ERROR,IPP,SOURCEID,IDENSTAT) ;this module files the individual entry
;PDFN is the patient's DFN
;FSTRG = institution or treating facility^Date of treatment^Event reason
;TICN - if 1 suppress add entries to ADT HL7 PIVOT (#391.71) file
;VAFCSLT - (optional) if 1 suppress exception logging and return error in the ERROR array
;ERROR - (optional)
;Ex 500^2960202^A1
;
N X,Y
I $G(VAFCSLT)="" S VAFCSLT=0
S X="MPIF001" X ^%ZOSF("TEST") Q:'$T
S X="MPIFQ0" X ^%ZOSF("TEST") Q:'$T
N TFIEN,PDLT,FAC,EVNTR,VAFCER,CMOR,ICN,STA,ECNT
S ECNT=1
S FAC=$P(FSTRG,U,1),PDLT=$P(FSTRG,U,2),EVNTR=$P(FSTRG,U,3)
S STA=$$STA^XUAF4(FAC)
;
I '$$FIND1^DIC(4,"","MX","`"_FAC) D Q
. I 'VAFCSLT D EXC^RGHLLOG(212,"Msg#"_$G(HL("MID"))_" unknown Institution IEN "_FAC_" passed into TF update.",PDFN) D STOP^RGHLLOG(1) Q
. I VAFCSLT S ERROR(STA)="Update of "_STA_" Failed at "_$P($$SITE^VASITE,"^",3)_" due to unknown Institution IEN "_FAC_" passed into TF update."
I PDLT'="" K %DT S %DT="T" S X=PDLT D ^%DT K %DT I Y<0 S VAFCER="1^Not a FM date." D Q
.I 'VAFCSLT D EXC^RGHLLOG(212,"TF updated in msg#"_$G(HL("MID"))_" for Institution IEN "_FAC_" but with invalid date "_PDLT_" for DFN "_PDFN,PDFN)
.I VAFCSLT S ERROR(STA)="Update of "_STA_" Failed at "_$P($$SITE^VASITE,"^",3)_" due to invalid date "_PDLT_" for DFN "_PDFN
;removed code for adding local ICN's
S ICN=+$$MPINODE^MPIFAPI(PDFN)
S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,FAC,0)) D
.;TFIEN is used in other places so quit after adding new entry
.I 'TFIEN D FILENEW(PDFN,FAC,PDLT,EVNTR,VAFCSLT,.ERROR,$G(IPP),$G(SOURCEID),$G(IDENSTAT)) Q
.I TFIEN D FILEDIT(TFIEN,PDLT,PDFN,FAC,EVNTR,VAFCSLT,.ERROR,$G(IPP),$G(SOURCEID),$G(IDENSTAT))
;look to see if CMOR is in TF list if not add
S CMOR=$$GETVCCI^MPIF001(PDFN)
S CMOR=$$LKUP^XUAF4(CMOR) ; **520 REMOVED +
;check to see if CMOR exist if not add it
I +$G(CMOR)>0 D:'$D(^DGCN(391.91,"APAT",PDFN,CMOR)) FILENEW^VAFCTFU(PDFN,CMOR)
;create the entry in the pivot to broadcast the MFU.
; Note: we will not broadcast to the MFU if the TFL record
; has an event reason. See comments in FILEDIT. *261 gjc@120199
I $G(TICN)'=1,$P($$SEND^VAFHUTL,"^",2)>0 D SETSND(PDFN)
FILEQ Q
;
FILENEW(PDFN,FAC,PDLT,EVNTR,VAFCSLT,ERROR,IPP,SOURCEID,IDENSTAT) ;
N DGSENFLG ;**240 added y
K DD,DO,DIC,DA,RESULT
S DGSENFLG=""
N FDA,FDAIEN,ERR S ERR=""
I $G(EVNTR)'="" D CHK^DIE(391.91,.07,"",EVNTR,.RESULT) I +RESULT>0 S EVNTR=RESULT
S FDA(1,391.91,"+1,",.01)=PDFN
S FDA(1,391.91,"+1,",.02)=FAC
S FDA(1,391.91,"+1,",.03)=$G(PDLT)
S FDA(1,391.91,"+1,",.07)=$G(EVNTR)
S FDA(1,391.91,"+1,",.08)=$G(IPP)
L +^DGCN(391.91,0):30
I '$D(^DGCN(391.91,"APAT",PDFN,FAC)) D UPDATE^DIE("","FDA(1)","FDAIEN","ERR") I $D(ERR("DIERR",1)) S ERROR(STA)="Add of "_STA_" Failed at "_$P($$SITE^VASITE,"^",3)_" due to "_$G(ERR("DIERR",1,"TEXT",1))
I $G(SOURCEID)'="",$G(FDAIEN(1))'="" D UPDSID(PDFN,FAC,SOURCEID,IDENSTAT,FDAIEN(1)) ;Update SourceID multiple
;removed code to add a subscription
L -^DGCN(391.91,0)
K DIC,DD,DO,DA
Q
;
UPDSID(PDFN,FAC,SID,IDSTAT,TFIEN) ;Update sourceid multiple
N FDA,DGENDA,FILE,IENS
S FILE=391.9101
I $D(^DGCN(391.91,TFIEN,1,"B",SID)) D Q ;Update existing sub record
. S DGENDA=$O(^DGCN(391.91,TFIEN,1,"B",SID,0))
. S DGENDA(1)=TFIEN,IENS=$$IENS^DILF(.DGENDA)
. S FDA(FILE,IENS,.01)=SID,FDA(FILE,IENS,1)=IDSTAT
. D FILE^DIE("K","FDA","ERRORS(1)")
;add new sub record
S DGENDA="+1",DGENDA(1)=TFIEN,IENS=$$IENS^DILF(.DGENDA)
S FDA(FILE,IENS,.01)=SID,FDA(FILE,IENS,1)=IDSTAT
D UPDATE^DIE("","FDA","IENA","ERRORS(1)")
Q
SETSND(PDFN) ;sets the pivot file entry to send MFU
;
N ANS,X
S X="MPIF001" X ^%ZOSF("TEST") Q:'$T
; check if other facilities other than CMOR in TF list
N SIT,CMOR,STOP
S CMOR=$$GETVCCI^MPIF001(PDFN)
S CMOR=$$LKUP^XUAF4(CMOR) ; **520 REMOVED +
I CMOR=$P($$SITE^VASITE,"^") D
.S SIT=0
.S SIT=$O(^DGCN(391.91,"APAT",PDFN,SIT))
.I SIT=CMOR S SIT=$O(^DGCN(391.91,"APAT",PDFN,SIT)) I SIT="" S STOP=""
I $D(STOP) QUIT
S ANS=$$PIVNW^VAFHPIVT(PDFN,DT,5,PDFN_";DPT(")
I 'ANS QUIT
D XMITFLAG^VAFCDD01(0,+ANS,0)
SETSNDQ Q
;
FILEDIT(TFIEN,PDLT,PDFN,FAC,EVNTR,VAFCSLT,ERROR,IPP,SOURCEID,IDENSTAT) ;
N DGSENFLG,FDA,FDAIEN,ERR,RESULT S DGSENFLG="",ERR=""
I $G(PDLT)'=""!($G(IPP)'="") D
.S TFIEN(0)=$G(^DGCN(391.91,TFIEN,0))
.I $G(EVNTR)'="" D CHK^DIE(391.91,.07,"",EVNTR,.RESULT) I +RESULT>0 S EVNTR=RESULT
.I $G(PDLT)'="" S FDA(1,391.91,+TFIEN_",",.03)=$G(PDLT)
.S FDA(1,391.91,+TFIEN_",",.07)=$G(EVNTR)
.I $G(IPP)'="" S FDA(1,391.91,+TFIEN_",",.08)=$G(IPP)
.D FILE^DIE("K","FDA(1)","ERR") I VAFCSLT I $D(ERR("DIERR",1)) S ERROR(STA)="Edit of "_STA_" Failed at "_$P($$SITE^VASITE,"^",3)_" due to "_$G(ERR("DIERR",1,"TEXT",1))
I $G(SOURCEID)'="" D UPDSID(PDFN,FAC,SOURCEID,IDENSTAT,TFIEN)
;remove code to add a subscription
Q
;
DELETETF(PAT,INST) ;deletion entry point
;This entry point is used to delete a single Treating Facility from
;the Treating Facility list.
;INPUT PAT - the ICN of the patient.
; INST - the IEN of the institution to be deleted.
;
;OUTPUT 0 (zero) - If no errors
; 1^error description if there was a problem
;
N VAFCER,PDFN,TFIEN,X,VAFCSCN,LINK,VAFCLLN,IEN
S VAFCER=0
I '$G(PAT)!('$G(INST)) S VAFCER="1^Parameter missing." S ERROR(INST)="212"_"^"_$G(HL("MID"))_"^"_"Delete Failed: "_$P(VAFCER,"^") G DELTFQ
S X="MPIF001" X ^%ZOSF("TEST") I '$T G FILETFQ
S PDFN=$$GETDFN^MPIF001(+PAT)
I PDFN<0 S VAFCER="1^No patient DFN." G FILETFQ
I '$$FIND1^DIC(4,"","MX","`"_INST) S VAFCER="1^Not an Institution IEN." G DELTFQ
S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,INST,0))
I 'TFIEN S VAFCER="1^Could not find Treating Facility." G DELTFQ
D DELETE(TFIEN)
S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,INST,0))
I TFIEN S VAFCER="1^DIK failed to delete entry" G DELTFQ
;terminate the subscription if there is one
S VAFCSCN=+$P($$MPINODE^MPIFAPI(PDFN),"^",5) I +$G(VAFCSCN)>0 D
.;get logical link
. D LINK^HLUTIL3(INST,.LINK) S VAFCLLN=$O(LINK(0)) I +$G(VAFCLLN)>0 S VAFCLLN=LINK(VAFCLLN) D UPD^HLSUB(VAFCSCN,VAFCLLN,0,,$$NOW^XLFDT,,.HLER)
D RETPDR^VAFCEHU2(PDFN,INST) ;**474 retire pdr when deleting tf
DELTFQ Q VAFCER
;
DELETE(TFIEN) ;the actual deletion code
;
K DIK,DA
S DIK="^DGCN(391.91,"
S DA=TFIEN
D ^DIK K DIK,DA
Q
;
DELALLTF(PAT) ;Entry point to delete all Treating Facilities for a single
;patient.
;INPUT PAT - The patient's ICN
;OUTPUT 0 (zero) - If no errors
; 1^error description if an error
;
N VAFCER,PDFN,LP,TFIEN,X
S VAFCER=0
I '$G(PAT) Q "1^Parameter missing."
S X="MPIF001" X ^%ZOSF("TEST") I '$T Q 0
S PDFN=$$GETDFN^MPIF001(PAT)
I PDFN<0 Q "1^No patient DFN."
F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:LP'>0 D
. S TFIEN=0
. F S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,LP,TFIEN)) Q:TFIEN'>0 D DELETE(TFIEN)
;
Q VAFCER
;
VAFCTFU ;ALB/JLU-UTILITIES FOR THE TREATING FACILITY FILE 391.91 ; 1/15/10 5:00pm
+1 ;;5.3;PIMS;**149,240,261,255,316,392,440,428,474,520,697,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;Reference to EXC^RGHLLOG and STOP^RGHLLOG supported by IA #2796
+4 ;Reference to $$UPDATE^ MPIFAPI supported by IA #2706
+5 ;
+6 ;CHKSUB & GETSCN line tags removed, patch DG*5.3*697
+7 ;Subscriptions are no longer used and errors are being
+8 ;generated when attempting to add a subscription.
+9 ;
FILETF(PAT,INST) ;programmer entry point.
+1 ;INPUT PAT - This is the patient's ICN
+2 ; INST - This is the IEN of the institution or Treating Facility
+3 ;it also contains the date of treatment in FM format. It is to be
+4 ;stored in an array structure to allow for multiple treating
+5 ;facilities.
+6 ; EX. X(1)=500^2960101
+7 ; x(2)=425^2960202
+8 ;
+9 ;OUTPUT 0 (ZERO) If no errors
+10 ; 1^error description if there was an error.
+11 ;
+12 NEW PDFN,LP,VAFCER,X
+13 SET VAFCER=0
+14 IF '$GET(PAT)!('$DATA(INST))
SET VAFCER="1^Parameter missing."
GOTO FILETFQ
+15 IF $DATA(@INST)<10
SET VAFCER="1^Institution array not populated."
GOTO FILETFQ
+16 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
GOTO FILETFQ
+17 SET PDFN=$$GETDFN^MPIF001(PAT)
+18 IF PDFN<0
SET VAFCER="1^No patient DFN."
GOTO FILETFQ
+19 NEW FSTRG
+20 FOR LP=0:0
SET LP=$ORDER(@INST@(LP))
IF 'LP
QUIT
DO FILE(PDFN,@INST@(LP))
+21 ;
FILETFQ QUIT VAFCER
+1 ;
+2 ; both the SET & QUERYTF subroutines have been moved to VAFCTFU1 as
+3 ; the result of DG*5.3*261 *261 gjc@120899
+4 ;
FILE(PDFN,FSTRG,TICN,VAFCSLT,ERROR,IPP,SOURCEID,IDENSTAT) ;this module files the individual entry
+1 ;PDFN is the patient's DFN
+2 ;FSTRG = institution or treating facility^Date of treatment^Event reason
+3 ;TICN - if 1 suppress add entries to ADT HL7 PIVOT (#391.71) file
+4 ;VAFCSLT - (optional) if 1 suppress exception logging and return error in the ERROR array
+5 ;ERROR - (optional)
+6 ;Ex 500^2960202^A1
+7 ;
+8 NEW X,Y
+9 IF $GET(VAFCSLT)=""
SET VAFCSLT=0
+10 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+11 SET X="MPIFQ0"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+12 NEW TFIEN,PDLT,FAC,EVNTR,VAFCER,CMOR,ICN,STA,ECNT
+13 SET ECNT=1
+14 SET FAC=$PIECE(FSTRG,U,1)
SET PDLT=$PIECE(FSTRG,U,2)
SET EVNTR=$PIECE(FSTRG,U,3)
+15 SET STA=$$STA^XUAF4(FAC)
+16 ;
+17 IF '$$FIND1^DIC(4,"","MX","`"_FAC)
Begin DoDot:1
+18 IF 'VAFCSLT
DO EXC^RGHLLOG(212,"Msg#"_$GET(HL("MID"))_" unknown Institution IEN "_FAC_" passed into TF update.",PDFN)
DO STOP^RGHLLOG(1)
QUIT
+19 IF VAFCSLT
SET ERROR(STA)="Update of "_STA_" Failed at "_$PIECE($$SITE^VASITE,"^",3)_" due to unknown Institution IEN "_FAC_" passed into TF update."
End DoDot:1
QUIT
+20 IF PDLT'=""
KILL %DT
SET %DT="T"
SET X=PDLT
DO ^%DT
KILL %DT
IF Y<0
SET VAFCER="1^Not a FM date."
Begin DoDot:1
+21 IF 'VAFCSLT
DO EXC^RGHLLOG(212,"TF updated in msg#"_$GET(HL("MID"))_" for Institution IEN "_FAC_" but with invalid date "_PDLT_" for DFN "_PDFN,PDFN)
+22 IF VAFCSLT
SET ERROR(STA)="Update of "_STA_" Failed at "_$PIECE($$SITE^VASITE,"^",3)_" due to invalid date "_PDLT_" for DFN "_PDFN
End DoDot:1
QUIT
+23 ;removed code for adding local ICN's
+24 SET ICN=+$$MPINODE^MPIFAPI(PDFN)
+25 SET TFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,FAC,0))
Begin DoDot:1
+26 ;TFIEN is used in other places so quit after adding new entry
+27 IF 'TFIEN
DO FILENEW(PDFN,FAC,PDLT,EVNTR,VAFCSLT,.ERROR,$GET(IPP),$GET(SOURCEID),$GET(IDENSTAT))
QUIT
+28 IF TFIEN
DO FILEDIT(TFIEN,PDLT,PDFN,FAC,EVNTR,VAFCSLT,.ERROR,$GET(IPP),$GET(SOURCEID),$GET(IDENSTAT))
End DoDot:1
+29 ;look to see if CMOR is in TF list if not add
+30 SET CMOR=$$GETVCCI^MPIF001(PDFN)
+31 ; **520 REMOVED +
SET CMOR=$$LKUP^XUAF4(CMOR)
+32 ;check to see if CMOR exist if not add it
+33 IF +$GET(CMOR)>0
IF '$DATA(^DGCN(391.91,"APAT",PDFN,CMOR))
DO FILENEW^VAFCTFU(PDFN,CMOR)
+34 ;create the entry in the pivot to broadcast the MFU.
+35 ; Note: we will not broadcast to the MFU if the TFL record
+36 ; has an event reason. See comments in FILEDIT. *261 gjc@120199
+37 IF $GET(TICN)'=1
IF $PIECE($$SEND^VAFHUTL,"^",2)>0
DO SETSND(PDFN)
FILEQ QUIT
+1 ;
FILENEW(PDFN,FAC,PDLT,EVNTR,VAFCSLT,ERROR,IPP,SOURCEID,IDENSTAT) ;
+1 ;**240 added y
NEW DGSENFLG
+2 KILL DD,DO,DIC,DA,RESULT
+3 SET DGSENFLG=""
+4 NEW FDA,FDAIEN,ERR
SET ERR=""
+5 IF $GET(EVNTR)'=""
DO CHK^DIE(391.91,.07,"",EVNTR,.RESULT)
IF +RESULT>0
SET EVNTR=RESULT
+6 SET FDA(1,391.91,"+1,",.01)=PDFN
+7 SET FDA(1,391.91,"+1,",.02)=FAC
+8 SET FDA(1,391.91,"+1,",.03)=$GET(PDLT)
+9 SET FDA(1,391.91,"+1,",.07)=$GET(EVNTR)
+10 SET FDA(1,391.91,"+1,",.08)=$GET(IPP)
+11 LOCK +^DGCN(391.91,0):30
+12 IF '$DATA(^DGCN(391.91,"APAT",PDFN,FAC))
DO UPDATE^DIE("","FDA(1)","FDAIEN","ERR")
IF $DATA(ERR("DIERR",1))
SET ERROR(STA)="Add of "_STA_" Failed at "_$PIECE($$SITE^VASITE,"^",3)_" due to "_$GET(ERR("DIERR",1,"TEXT",1))
+13 ;Update SourceID multiple
IF $GET(SOURCEID)'=""
IF $GET(FDAIEN(1))'=""
DO UPDSID(PDFN,FAC,SOURCEID,IDENSTAT,FDAIEN(1))
+14 ;removed code to add a subscription
+15 LOCK -^DGCN(391.91,0)
+16 KILL DIC,DD,DO,DA
+17 QUIT
+18 ;
UPDSID(PDFN,FAC,SID,IDSTAT,TFIEN) ;Update sourceid multiple
+1 NEW FDA,DGENDA,FILE,IENS
+2 SET FILE=391.9101
+3 ;Update existing sub record
IF $DATA(^DGCN(391.91,TFIEN,1,"B",SID))
Begin DoDot:1
+4 SET DGENDA=$ORDER(^DGCN(391.91,TFIEN,1,"B",SID,0))
+5 SET DGENDA(1)=TFIEN
SET IENS=$$IENS^DILF(.DGENDA)
+6 SET FDA(FILE,IENS,.01)=SID
SET FDA(FILE,IENS,1)=IDSTAT
+7 DO FILE^DIE("K","FDA","ERRORS(1)")
End DoDot:1
QUIT
+8 ;add new sub record
+9 SET DGENDA="+1"
SET DGENDA(1)=TFIEN
SET IENS=$$IENS^DILF(.DGENDA)
+10 SET FDA(FILE,IENS,.01)=SID
SET FDA(FILE,IENS,1)=IDSTAT
+11 DO UPDATE^DIE("","FDA","IENA","ERRORS(1)")
+12 QUIT
SETSND(PDFN) ;sets the pivot file entry to send MFU
+1 ;
+2 NEW ANS,X
+3 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+4 ; check if other facilities other than CMOR in TF list
+5 NEW SIT,CMOR,STOP
+6 SET CMOR=$$GETVCCI^MPIF001(PDFN)
+7 ; **520 REMOVED +
SET CMOR=$$LKUP^XUAF4(CMOR)
+8 IF CMOR=$PIECE($$SITE^VASITE,"^")
Begin DoDot:1
+9 SET SIT=0
+10 SET SIT=$ORDER(^DGCN(391.91,"APAT",PDFN,SIT))
+11 IF SIT=CMOR
SET SIT=$ORDER(^DGCN(391.91,"APAT",PDFN,SIT))
IF SIT=""
SET STOP=""
End DoDot:1
+12 IF $DATA(STOP)
QUIT
+13 SET ANS=$$PIVNW^VAFHPIVT(PDFN,DT,5,PDFN_";DPT(")
+14 IF 'ANS
QUIT
+15 DO XMITFLAG^VAFCDD01(0,+ANS,0)
SETSNDQ QUIT
+1 ;
FILEDIT(TFIEN,PDLT,PDFN,FAC,EVNTR,VAFCSLT,ERROR,IPP,SOURCEID,IDENSTAT) ;
+1 NEW DGSENFLG,FDA,FDAIEN,ERR,RESULT
SET DGSENFLG=""
SET ERR=""
+2 IF $GET(PDLT)'=""!($GET(IPP)'="")
Begin DoDot:1
+3 SET TFIEN(0)=$GET(^DGCN(391.91,TFIEN,0))
+4 IF $GET(EVNTR)'=""
DO CHK^DIE(391.91,.07,"",EVNTR,.RESULT)
IF +RESULT>0
SET EVNTR=RESULT
+5 IF $GET(PDLT)'=""
SET FDA(1,391.91,+TFIEN_",",.03)=$GET(PDLT)
+6 SET FDA(1,391.91,+TFIEN_",",.07)=$GET(EVNTR)
+7 IF $GET(IPP)'=""
SET FDA(1,391.91,+TFIEN_",",.08)=$GET(IPP)
+8 DO FILE^DIE("K","FDA(1)","ERR")
IF VAFCSLT
IF $DATA(ERR("DIERR",1))
SET ERROR(STA)="Edit of "_STA_" Failed at "_$PIECE($$SITE^VASITE,"^",3)_" due to "_$GET(ERR("DIERR",1,"TEXT",1))
End DoDot:1
+9 IF $GET(SOURCEID)'=""
DO UPDSID(PDFN,FAC,SOURCEID,IDENSTAT,TFIEN)
+10 ;remove code to add a subscription
+11 QUIT
+12 ;
DELETETF(PAT,INST) ;deletion entry point
+1 ;This entry point is used to delete a single Treating Facility from
+2 ;the Treating Facility list.
+3 ;INPUT PAT - the ICN of the patient.
+4 ; INST - the IEN of the institution to be deleted.
+5 ;
+6 ;OUTPUT 0 (zero) - If no errors
+7 ; 1^error description if there was a problem
+8 ;
+9 NEW VAFCER,PDFN,TFIEN,X,VAFCSCN,LINK,VAFCLLN,IEN
+10 SET VAFCER=0
+11 IF '$GET(PAT)!('$GET(INST))
SET VAFCER="1^Parameter missing."
SET ERROR(INST)="212"_"^"_$GET(HL("MID"))_"^"_"Delete Failed: "_$PIECE(VAFCER,"^")
GOTO DELTFQ
+12 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
GOTO FILETFQ
+13 SET PDFN=$$GETDFN^MPIF001(+PAT)
+14 IF PDFN<0
SET VAFCER="1^No patient DFN."
GOTO FILETFQ
+15 IF '$$FIND1^DIC(4,"","MX","`"_INST)
SET VAFCER="1^Not an Institution IEN."
GOTO DELTFQ
+16 SET TFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,INST,0))
+17 IF 'TFIEN
SET VAFCER="1^Could not find Treating Facility."
GOTO DELTFQ
+18 DO DELETE(TFIEN)
+19 SET TFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,INST,0))
+20 IF TFIEN
SET VAFCER="1^DIK failed to delete entry"
GOTO DELTFQ
+21 ;terminate the subscription if there is one
+22 SET VAFCSCN=+$PIECE($$MPINODE^MPIFAPI(PDFN),"^",5)
IF +$GET(VAFCSCN)>0
Begin DoDot:1
+23 ;get logical link
+24 DO LINK^HLUTIL3(INST,.LINK)
SET VAFCLLN=$ORDER(LINK(0))
IF +$GET(VAFCLLN)>0
SET VAFCLLN=LINK(VAFCLLN)
DO UPD^HLSUB(VAFCSCN,VAFCLLN,0,,$$NOW^XLFDT,,.HLER)
End DoDot:1
+25 ;**474 retire pdr when deleting tf
DO RETPDR^VAFCEHU2(PDFN,INST)
DELTFQ QUIT VAFCER
+1 ;
DELETE(TFIEN) ;the actual deletion code
+1 ;
+2 KILL DIK,DA
+3 SET DIK="^DGCN(391.91,"
+4 SET DA=TFIEN
+5 DO ^DIK
KILL DIK,DA
+6 QUIT
+7 ;
DELALLTF(PAT) ;Entry point to delete all Treating Facilities for a single
+1 ;patient.
+2 ;INPUT PAT - The patient's ICN
+3 ;OUTPUT 0 (zero) - If no errors
+4 ; 1^error description if an error
+5 ;
+6 NEW VAFCER,PDFN,LP,TFIEN,X
+7 SET VAFCER=0
+8 IF '$GET(PAT)
QUIT "1^Parameter missing."
+9 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT 0
+10 SET PDFN=$$GETDFN^MPIF001(PAT)
+11 IF PDFN<0
QUIT "1^No patient DFN."
+12 FOR LP=0:0
SET LP=$ORDER(^DGCN(391.91,"APAT",PDFN,LP))
IF LP'>0
QUIT
Begin DoDot:1
+13 SET TFIEN=0
+14 FOR
SET TFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,LP,TFIEN))
IF TFIEN'>0
QUIT
DO DELETE(TFIEN)
End DoDot:1
+15 ;
+16 QUIT VAFCER
+17 ;
