BQICEADD ;GDHD/HCS/ALA-CMET Add Event ; 09 Jan 2017 9:12 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
EN(DATA,DFN,PARMS) ;EP -- BQI ADD NEW EVENT
NEW CIEN
NEW ARLDTM
;S ARLDTM=$$NOW^XLFDT()
;S ^ARLPARMS("BQICEADD",ARLDTM,"DFN")=DFN
;S ^ARLPARMS("BQICEADD",ARLDTM,"PARMS")=$G(PARMS)
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQICEADD",UID))
S MORE=$G(MORE,1)
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQICEADD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT^I00010QUEUED_CMET_IEN"_$C(30)
;
; Get the parameters
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
; Parse the visit parameters
K APCDALVR
F BQ=1:1:$L(PARMS,$C(28)) D
. NEW VFIEN,PTYP
. S VFIEN=$$FIND1^DIC(90506.3,"","MX","CMET Add Event","","","ERROR")
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,"")) Q:PFIEN=""
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. ;I "AD"[$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1) S VALUE=$$DATE^BQIUL1(VALUE)
. I PTYP="A"!(PTYP="D") S VALUE=$$DATE^BQIUL1(VALUE)
. I PTYP="W" D Q
.. K BTPWP D WP(VALUE)
. S @NAME=VALUE
;
F BQ=1:1:$L(PARMS,$C(28)) D
. NEW VFIEN
. S VFIEN=$$FIND1^DIC(90506.3,"","MX","PCC Visit","","","ERROR")
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" Q
. I NAME="APCCDATE" S @NAME=VALUE
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,"")) Q:PFIEN=""
. I "AD"[$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1) S VALUE=$$DATE^BQIUL1(VALUE)
. I $P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S APCDALVR(NAME)=VALUE
S APCDALVR("APCDPAT")=DFN,APCDPAT=DFN
S APCDALVR("APCDANE")="",APCDALVR("AUPNTALK")=""
S APCDALVR("APCDLOC")=$S($G(APCDALVR("APCDLOC"))'="":APCDALVR("APCDLOC"),1:$$OLOC())
S APCDALVR("APCDTYPE")=$G(APCDALVR("APCDTYPE"),"I")
S APCDALVR("APCDCAT")=$G(APCDALVR("APCDCAT"),"E")
S APCDALVR("APCDCLN")=$G(CLN,"OTHER")
S APCDDATE=$$DATE^BQIUL1(APCCDATE)
I $G(MORE)'="" S APCDALVR("APCDAUTO")=1
S APCDALVR("APCDOPT")=$$FIND1^DIC(19,"","BX","BQIRPC","","","ERROR")
;
; Create visit and then update other Vfiles
D EN^APCDALV
; Check for error
I '$G(APCDALVR("APCDAFLG")) S VISIT=$G(APCDALVR("APCDVSIT"))
E S RESULT=-1 G DONE
;
; If there is an outside provider, set it separately
I $G(APCDALVR("APCDTOPR"))'="" D
. S BQIUPD(9000010,VISIT_",",1210)=$G(APCDALVR("APCDTOPR"))
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
;
; Determine the input template for the event
S VFIEN=$O(^BTPW(90621.1,"D",EVTYPE,"")),FRIL=VFIEN
S VFILE=$$GET1^DIQ(90621.1,VFIEN_",",.02,"E")
S FREF=$$GET1^DIQ(90621.1,VFIEN_",",.02,"I")
S APCDALVR("APCDATMP")="[APCDALVR "_FREF_" (ADD)]"
I EVTYPE="CPT" S APCDALVR("APCDTCPT")=$P(^ICPT(IVALIEN,0),"^",1),APCDALVR("APCDTUN")=1,APCDALVR("APCDTPN")=$$ENARR()
I EVTYPE="POV" S APCDALVR("APCDTPOV")=$P(^ICD9(IVALIEN,0),"^",1),APCDALVR("APCDTNQ")=$$ENARR(),APCDALVR("APCDTPS")="PRIMARY"
I EVTYPE="LAB" S APCDALVR("APCDTLAB")=IVALIEN,APCDALVR("APCDTLPV")=$$ENARR(),APCDALVR("APCDTCSF")="RESULTED"
I EVTYPE="PROCEDURE" S APCDALVR("APCDTPRC")=$P(^ICD0(IVALIEN,0),"^",1),APCDALVR("APCDTNQ")=$$ENARR(),APCDALVR("APCDTPP")="YES"
;
; Create V files
D EN^APCDALVR
; Check for error
I '$G(APCDALVR("APCDAFLG")) S RESULT=1
E S RESULT=-1
; Cleanup
K APCDALVR
I RESULT=1 D
. S GREF=$$ROOT^DILFD(FREF,"",1)
. S RIEN=$O(@GREF@("AD",VISIT,""))
. D CM
;
I RESULT=-1 D
. NEW DA,DIK
. S DIK="^AUPNVSIT(",DA=VISIT D ^DIK
;
DONE ;
S II=II+1,@DATA@(II)=RESULT_U_$G(CIEN)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
K AGE,APCCDATE,APCDDATE,APCDANE,APCDLOC,APCDLOC,BQ,DA,DFN,DOB,EVIEN,EVNAME,EVTYPE,FREF,FRIL,IENS
K GREFF,II,IVALIEN,MORE,NAME,PARMS,PDATA,PFIEN,RESULT,RIEN,SEX,SSN,VALUE,VFIEN,VFILE,VISIT,VSDTM
K ^UTILITY($J)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $G(II)="" S II=0
I $G(UID)="" S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
I $G(DATA)="" S DATA=$NA(^TMP("BQICEADD",UID))
S II=II+1,@DATA@(II)=$C(31)
Q
;
CM ;EP
NEW DIC,DLAYGO,X,Y,BTPUPD
S DIC="^BTPWQ(",DIC(0)="LMNZ",DLAYGO=90629,DIC("P")=DLAYGO
S X=EVIEN
K DO,DD D FILE^DICN
S CIEN=+Y
D UPD(CIEN)
D CHK
Q
;
UPD(CIEN) ;
S VSDTM=$P(^AUPNVSIT(VISIT,0),"^",1),IENS=CIEN_","
S BTPUPD(90629,IENS,.02)=DFN,BTPUPD(90629,IENS,.03)=VSDTM
S BTPUPD(90629,IENS,.04)=VISIT,BTPUPD(90629,IENS,.05)=RIEN
S BTPUPD(90629,IENS,.06)=FRIL,BTPUPD(90629,IENS,.07)=$$NOW^XLFDT()
S BTPUPD(90629,IENS,.09)=$G(WHIEN),BTPUPD(90629,IENS,.1)=$G(RARPT)
S BTPUPD(90629,IENS,.15)=$G(ACCN)
S BTPUPD(90629,IENS,.08)="P",BTPUPD(90629,IENS,.12)="Add Manual Event"
S BTPUPD(90629,IENS,.13)=$$CAT^BTPWPDSP(EVIEN,1),BTPUPD(90629,IENS,.11)=$$NOW^XLFDT()
S BTPUPD(90629,IENS,.16)=$$GET1^DIQ(9000010,VISIT_",",.06,"I")
S BTPUPD(90629,IENS,1.02)=$G(BTPWPFND)
D FILE^DIE("","BTPUPD","ERROR")
I $D(BTPWP) D WP^DIE(90629,IENS,4,"","BTPWP","ERROR") K BTPWP
Q
;
CHK ; Check to supercede previously existing record
NEW PIEN,BTPUPD
S PIEN=""
F S PIEN=$O(^BTPWQ("AD",DFN,PIEN)) Q:PIEN="" D
. I $P(^BTPWQ(PIEN,0),U,1)'=EVIEN Q
. I PIEN=CIEN Q
. I VSDTM>$P(^BTPWQ(PIEN,0),U,3) Q
. I $P(^BTPWQ(PIEN,0),U,8)="P" D
.. S BTPUPD(90629,PIEN_",",.08)="S"
.. D FILE^DIE("","BTPUPD","ERROR")
;
; Check for possible match with future followup
NEW TIEN
S TIEN=""
F S TIEN=$O(^BTPWP("AE",DFN,"F",TIEN)) Q:TIEN="" D
. I $P(^BTPWP(TIEN,0),U,1)'=EVIEN Q
. S BTPUPD(90629,CIEN_",",1.01)=TIEN
. D FILE^DIE("","BTPUPD","ERROR")
Q
;
OLOC() ;EP - Other location
NEW PRMN,DOM,DIV
S PRMN=$O(^XTV(8989.51,"B","BEHOENCX OTHER LOCATION",""))
S DOM=$P(^XTV(8989.3,1,0),"^",1)
S DIV=$G(DUZ(2))
S APCDLOC=DIV
S IEN=$O(^XTV(8989.5,"AC",PRMN,DIV_";DIC(4,","")),APCDLOC=^XTV(8989.5,"AC",PRMN,DIV_";DIC(4,",IEN)
I IEN="" S IEN=$O(^XTV(8989.5,"AC",PRMN,DOM_";DIC(4.2,","")),APCDLOC=^XTV(8989.5,"AC",PRMN,DOM_";DIC(4.2,",IEN)
Q APCDLOC
;
ENARR() ;EP - Event Narrative
NEW TEXT
;I $G(APCDLOC)="" S APCDLOC=$G(APCDALVR("APCDLOC"))
;I APCDLOC'="" S TEXT="Event "_EVNAME_" done at "_$P(^DIC(4,APCDLOC,0),"^",1)_" location"
S TEXT="CMET manually entered event"
Q TEXT
;
WP(X) ;EP - Process comment
NEW DIWL,DIWR,BQN
K ^UTILITY($J,"W")
S DIWL=1,DIWR=70
D ^DIWP
S BQN=""
F S BQN=$O(^UTILITY($J,"W",1,BQN)) Q:BQN="" S BTPWP(BQN)=^UTILITY($J,"W",1,BQN,0)
Q
BQICEADD ;GDHD/HCS/ALA-CMET Add Event ; 09 Jan 2017 9:12 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
EN(DATA,DFN,PARMS) ;EP -- BQI ADD NEW EVENT
+1 NEW CIEN
+2 NEW ARLDTM
+3 ;S ARLDTM=$$NOW^XLFDT()
+4 ;S ^ARLPARMS("BQICEADD",ARLDTM,"DFN")=DFN
+5 ;S ^ARLPARMS("BQICEADD",ARLDTM,"PARMS")=$G(PARMS)
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BQICEADD",UID))
+8 SET MORE=$GET(MORE,1)
+9 KILL @DATA
+10 SET II=0
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQICEADD D UNWIND^%ZTER"
+12 ;
+13 SET @DATA@(II)="I00010RESULT^I00010QUEUED_CMET_IEN"_$CHAR(30)
+14 ;
+15 ; Get the parameters
+16 SET PARMS=$GET(PARMS,"")
+17 IF PARMS=""
Begin DoDot:1
+18 SET LIST=""
SET BN=""
+19 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+20 KILL PARMS
+21 SET PARMS=LIST
+22 KILL LIST
End DoDot:1
+23 ;
+24 ; Parse the visit parameters
+25 KILL APCDALVR
+26 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+27 NEW VFIEN,PTYP
+28 SET VFIEN=$$FIND1^DIC(90506.3,"","MX","CMET Add Event","","","ERROR")
+29 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+30 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+31 IF VALUE=""
QUIT
+32 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
IF PFIEN=""
QUIT
+33 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+34 ;I "AD"[$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1) S VALUE=$$DATE^BQIUL1(VALUE)
+35 IF PTYP="A"!(PTYP="D")
SET VALUE=$$DATE^BQIUL1(VALUE)
+36 IF PTYP="W"
Begin DoDot:2
+37 KILL BTPWP
DO WP(VALUE)
End DoDot:2
QUIT
+38 SET @NAME=VALUE
End DoDot:1
+39 ;
+40 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+41 NEW VFIEN
+42 SET VFIEN=$$FIND1^DIC(90506.3,"","MX","PCC Visit","","","ERROR")
+43 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+44 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+45 IF VALUE=""
QUIT
+46 IF NAME="APCCDATE"
SET @NAME=VALUE
+47 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
IF PFIEN=""
QUIT
+48 IF "AD"[$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
SET VALUE=$$DATE^BQIUL1(VALUE)
+49 IF $PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)="C"
Begin DoDot:2
+50 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+51 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+52 SET APCDALVR(NAME)=VALUE
End DoDot:1
+53 SET APCDALVR("APCDPAT")=DFN
SET APCDPAT=DFN
+54 SET APCDALVR("APCDANE")=""
SET APCDALVR("AUPNTALK")=""
+55 SET APCDALVR("APCDLOC")=$SELECT($GET(APCDALVR("APCDLOC"))'="":APCDALVR("APCDLOC"),1:$$OLOC())
+56 SET APCDALVR("APCDTYPE")=$GET(APCDALVR("APCDTYPE"),"I")
+57 SET APCDALVR("APCDCAT")=$GET(APCDALVR("APCDCAT"),"E")
+58 SET APCDALVR("APCDCLN")=$GET(CLN,"OTHER")
+59 SET APCDDATE=$$DATE^BQIUL1(APCCDATE)
+60 IF $GET(MORE)'=""
SET APCDALVR("APCDAUTO")=1
+61 SET APCDALVR("APCDOPT")=$$FIND1^DIC(19,"","BX","BQIRPC","","","ERROR")
+62 ;
+63 ; Create visit and then update other Vfiles
+64 DO EN^APCDALV
+65 ; Check for error
+66 IF '$GET(APCDALVR("APCDAFLG"))
SET VISIT=$GET(APCDALVR("APCDVSIT"))
+67 IF '$TEST
SET RESULT=-1
GOTO DONE
+68 ;
+69 ; If there is an outside provider, set it separately
+70 IF $GET(APCDALVR("APCDTOPR"))'=""
Begin DoDot:1
+71 SET BQIUPD(9000010,VISIT_",",1210)=$GET(APCDALVR("APCDTOPR"))
+72 DO FILE^DIE("","BQIUPD","ERROR")
+73 KILL BQIUPD
End DoDot:1
+74 ;
+75 ; Determine the input template for the event
+76 SET VFIEN=$ORDER(^BTPW(90621.1,"D",EVTYPE,""))
SET FRIL=VFIEN
+77 SET VFILE=$$GET1^DIQ(90621.1,VFIEN_",",.02,"E")
+78 SET FREF=$$GET1^DIQ(90621.1,VFIEN_",",.02,"I")
+79 SET APCDALVR("APCDATMP")="[APCDALVR "_FREF_" (ADD)]"
+80 IF EVTYPE="CPT"
SET APCDALVR("APCDTCPT")=$PIECE(^ICPT(IVALIEN,0),"^",1)
SET APCDALVR("APCDTUN")=1
SET APCDALVR("APCDTPN")=$$ENARR()
+81 IF EVTYPE="POV"
SET APCDALVR("APCDTPOV")=$PIECE(^ICD9(IVALIEN,0),"^",1)
SET APCDALVR("APCDTNQ")=$$ENARR()
SET APCDALVR("APCDTPS")="PRIMARY"
+82 IF EVTYPE="LAB"
SET APCDALVR("APCDTLAB")=IVALIEN
SET APCDALVR("APCDTLPV")=$$ENARR()
SET APCDALVR("APCDTCSF")="RESULTED"
+83 IF EVTYPE="PROCEDURE"
SET APCDALVR("APCDTPRC")=$PIECE(^ICD0(IVALIEN,0),"^",1)
SET APCDALVR("APCDTNQ")=$$ENARR()
SET APCDALVR("APCDTPP")="YES"
+84 ;
+85 ; Create V files
+86 DO EN^APCDALVR
+87 ; Check for error
+88 IF '$GET(APCDALVR("APCDAFLG"))
SET RESULT=1
+89 IF '$TEST
SET RESULT=-1
+90 ; Cleanup
+91 KILL APCDALVR
+92 IF RESULT=1
Begin DoDot:1
+93 SET GREF=$$ROOT^DILFD(FREF,"",1)
+94 SET RIEN=$ORDER(@GREF@("AD",VISIT,""))
+95 DO CM
End DoDot:1
+96 ;
+97 IF RESULT=-1
Begin DoDot:1
+98 NEW DA,DIK
+99 SET DIK="^AUPNVSIT("
SET DA=VISIT
DO ^DIK
End DoDot:1
+100 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=RESULT_U_$GET(CIEN)_$CHAR(30)
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 KILL AGE,APCCDATE,APCDDATE,APCDANE,APCDLOC,APCDLOC,BQ,DA,DFN,DOB,EVIEN,EVNAME,EVTYPE,FREF,FRIL,IENS
+4 KILL GREFF,II,IVALIEN,MORE,NAME,PARMS,PDATA,PFIEN,RESULT,RIEN,SEX,SSN,VALUE,VFIEN,VFILE,VISIT,VSDTM
+5 KILL ^UTILITY($JOB)
+6 QUIT
+7 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $GET(II)=""
SET II=0
+6 IF $GET(UID)=""
SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 IF $GET(DATA)=""
SET DATA=$NAME(^TMP("BQICEADD",UID))
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
CM ;EP
+1 NEW DIC,DLAYGO,X,Y,BTPUPD
+2 SET DIC="^BTPWQ("
SET DIC(0)="LMNZ"
SET DLAYGO=90629
SET DIC("P")=DLAYGO
+3 SET X=EVIEN
+4 KILL DO,DD
DO FILE^DICN
+5 SET CIEN=+Y
+6 DO UPD(CIEN)
+7 DO CHK
+8 QUIT
+9 ;
UPD(CIEN) ;
+1 SET VSDTM=$PIECE(^AUPNVSIT(VISIT,0),"^",1)
SET IENS=CIEN_","
+2 SET BTPUPD(90629,IENS,.02)=DFN
SET BTPUPD(90629,IENS,.03)=VSDTM
+3 SET BTPUPD(90629,IENS,.04)=VISIT
SET BTPUPD(90629,IENS,.05)=RIEN
+4 SET BTPUPD(90629,IENS,.06)=FRIL
SET BTPUPD(90629,IENS,.07)=$$NOW^XLFDT()
+5 SET BTPUPD(90629,IENS,.09)=$GET(WHIEN)
SET BTPUPD(90629,IENS,.1)=$GET(RARPT)
+6 SET BTPUPD(90629,IENS,.15)=$GET(ACCN)
+7 SET BTPUPD(90629,IENS,.08)="P"
SET BTPUPD(90629,IENS,.12)="Add Manual Event"
+8 SET BTPUPD(90629,IENS,.13)=$$CAT^BTPWPDSP(EVIEN,1)
SET BTPUPD(90629,IENS,.11)=$$NOW^XLFDT()
+9 SET BTPUPD(90629,IENS,.16)=$$GET1^DIQ(9000010,VISIT_",",.06,"I")
+10 SET BTPUPD(90629,IENS,1.02)=$GET(BTPWPFND)
+11 DO FILE^DIE("","BTPUPD","ERROR")
+12 IF $DATA(BTPWP)
DO WP^DIE(90629,IENS,4,"","BTPWP","ERROR")
KILL BTPWP
+13 QUIT
+14 ;
CHK ; Check to supercede previously existing record
+1 NEW PIEN,BTPUPD
+2 SET PIEN=""
+3 FOR
SET PIEN=$ORDER(^BTPWQ("AD",DFN,PIEN))
IF PIEN=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^BTPWQ(PIEN,0),U,1)'=EVIEN
QUIT
+5 IF PIEN=CIEN
QUIT
+6 IF VSDTM>$PIECE(^BTPWQ(PIEN,0),U,3)
QUIT
+7 IF $PIECE(^BTPWQ(PIEN,0),U,8)="P"
Begin DoDot:2
+8 SET BTPUPD(90629,PIEN_",",.08)="S"
+9 DO FILE^DIE("","BTPUPD","ERROR")
End DoDot:2
End DoDot:1
+10 ;
+11 ; Check for possible match with future followup
+12 NEW TIEN
+13 SET TIEN=""
+14 FOR
SET TIEN=$ORDER(^BTPWP("AE",DFN,"F",TIEN))
IF TIEN=""
QUIT
Begin DoDot:1
+15 IF $PIECE(^BTPWP(TIEN,0),U,1)'=EVIEN
QUIT
+16 SET BTPUPD(90629,CIEN_",",1.01)=TIEN
+17 DO FILE^DIE("","BTPUPD","ERROR")
End DoDot:1
+18 QUIT
+19 ;
OLOC() ;EP - Other location
+1 NEW PRMN,DOM,DIV
+2 SET PRMN=$ORDER(^XTV(8989.51,"B","BEHOENCX OTHER LOCATION",""))
+3 SET DOM=$PIECE(^XTV(8989.3,1,0),"^",1)
+4 SET DIV=$GET(DUZ(2))
+5 SET APCDLOC=DIV
+6 SET IEN=$ORDER(^XTV(8989.5,"AC",PRMN,DIV_";DIC(4,",""))
SET APCDLOC=^XTV(8989.5,"AC",PRMN,DIV_";DIC(4,",IEN)
+7 IF IEN=""
SET IEN=$ORDER(^XTV(8989.5,"AC",PRMN,DOM_";DIC(4.2,",""))
SET APCDLOC=^XTV(8989.5,"AC",PRMN,DOM_";DIC(4.2,",IEN)
+8 QUIT APCDLOC
+9 ;
ENARR() ;EP - Event Narrative
+1 NEW TEXT
+2 ;I $G(APCDLOC)="" S APCDLOC=$G(APCDALVR("APCDLOC"))
+3 ;I APCDLOC'="" S TEXT="Event "_EVNAME_" done at "_$P(^DIC(4,APCDLOC,0),"^",1)_" location"
+4 SET TEXT="CMET manually entered event"
+5 QUIT TEXT
+6 ;
WP(X) ;EP - Process comment
+1 NEW DIWL,DIWR,BQN
+2 KILL ^UTILITY($JOB,"W")
+3 SET DIWL=1
SET DIWR=70
+4 DO ^DIWP
+5 SET BQN=""
+6 FOR
SET BQN=$ORDER(^UTILITY($JOB,"W",1,BQN))
IF BQN=""
QUIT
SET BTPWP(BQN)=^UTILITY($JOB,"W",1,BQN,0)
+7 QUIT
