BQIRGADD ;PRXM/HC/ALA-Save patient register data ; 16 Nov 2007 1:18 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
EN(DATA,BQIREG,BQIDFN,BQIEN,BQITYP,PARMS) ; EP - BQI SAVE REGISTER DATA
; Input parameters
; BQIREG - Register or sub-register name
; BQIDFN - Patient IEN
; BQIEN - Record IEN, if one was passed out to GUI
; BQITYP - What is to happen to the record (A=Add, E=Edit, D=Delete)
; PARMS - Parameters and their values
;
NEW UID,II,ADD,BN,BQ,VFIEN,BQWP,PDATA,NAME,VALUE,PFIEN,PTYPE,RVIEN,FILE,FIELD
NEW BQQI,BQIDATA,BQIASRG,SUB,RGDATA,XREF,SUBREG,GLBREF,GLBNOD,DA,DIK,BKMSTAT
NEW BQFLD,BQJ,BWDATA,DFIELD,DFILE,NWIENS
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRGADD",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGADD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
;
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
;
I $G(PARMS)="",BQITYP'="D" Q
I BQIREG="" S BMXSEC="RPC Call Failed: Register not passed in." Q
S VFIEN=$O(^BQI(90506.3,"B",BQIREG,""))
I VFIEN="" S BMXSEC="RPC Call Failed: "_BQIREG_" does not exist." Q
K BQWP
F BQ=1:1:$L(PARMS,$C(28)) D
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" S VALUE="@"
. I NAME="BKMWHOM" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. S PTYP=$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
. I PTYP="D",VALUE'="@" S VALUE=$$DATE^BQIUL1(VALUE)
. ;I PTYP="T" S VALUE="`"_VALUE
. S RVIEN=$O(^BQI(90506.1,"B",NAME,"")) I RVIEN="" Q
. S DFILE=$P(^BQI(90506.1,RVIEN,0),U,5)
. S DFIELD=$P(^BQI(90506.1,RVIEN,0),U,6)
. I PTYP="W" D Q
.. I VALUE="@" S BQIDATA(DFILE,DFIELD)=VALUE Q
.. F BQQI=1:1 S BQJ=$P(VALUE,$C(10),BQQI) Q:BQJ="" D
... S BQWP(DFILE,DFIELD,BQQI)=BQJ
. I DFIELD'=".001" S BQIDATA(DFILE,DFIELD)=VALUE
;
; Check for register or subregister
S BQIASRG=""
S SUB=$P(^BQI(90506.3,VFIEN,0),U,8)
I SUB'="" D
. S BQIREG=$P(^BQI(90506.3,SUB,0),U,1)
. S HFIL=$P(^BQI(90506.3,SUB,0),U,10)
. S HFLD=$P(^BQI(90506.3,SUB,0),U,11)
. S HFIL=$P(^BQI(90506.3,VFIEN,0),U,10)
. S HFLD=$P(^BQI(90506.3,VFIEN,0),U,11)
S BQIASRG=$O(^BQI(90507,"B",BQIREG,""))
I BQIASRG'="" D
. S RGDATA=^BQI(90507,BQIASRG,0)
. S FILE=$P(RGDATA,U,7),XREF=$P(RGDATA,U,6)
. S ADD=$G(^BQI(90507,BQIASRG,2))
. I $G(SUBREG)="" S SUBREG=$P(RGDATA,U,9)
. S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
. S GLBNOD=$$ROOT^DILFD(FILE,"",1)
. I GLBNOD="" Q
;
; If the register global doesn't exist, quit
I '$D(@GLBNOD@(0)) Q
;
; If the patient is not already in the register, add them else update their record
S BKMDFN=BQIDFN,HFIL=$G(HFIL,""),HFLD=$G(HFLD,"")
X ADD
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
SAV(BQIUPD,IENS) ;EP - Set the data
;
K BQIWP
S BQFIL=""
F S BQFIL=$O(BQIDATA(BQFIL)) Q:BQFIL="" D
. S BQFLD=""
. F S BQFLD=$O(BQIDATA(BQFIL,BQFLD)) Q:BQFLD="" D
.. S BQIUPD(BQFIL,IENS,BQFLD)=BQIDATA(BQFIL,BQFLD)
;
I $D(BQWP),SUB="" D WP(IENS)
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 $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
WP(WIENS) ;EP - Set up word-processing array
S BQFIL=""
F S BQFIL=$O(BQWP(BQFIL)) Q:BQFIL="" D
. S BQFLD=""
. F S BQFLD=$O(BQWP(BQFIL,BQFLD)) Q:BQFLD="" D
.. S BQN=""
.. F S BQN=$O(BQWP(BQFIL,BQFLD,BQN)) Q:BQN="" D
... S BQIWP(BQFIL,WIENS,BQFLD,BQN)=BQWP(BQFIL,BQFLD,BQN)
Q
;
AST(BQDFN) ;EP - Add patient to Asthma Register
NEW DINUM,X,DIC,DLAYGO,DA,DR,DIE
S (DINUM,X)=BQDFN,DIC(0)="L",DIC="^BATREG("
S DIC("DR")=".02///U",DLAYGO=90181.01,DIADD=1
K DO,DD D FILE^DICN K DINUM,DLAYGO,DIADD
S DA=+Y I DA=-1 Q
S DIE=DIC
S DR=".05///^S X=$$LASTAV^BATU(BQIDFN,1);.06///^S X=$$LASTAV^BATU(BQIDFN,2);.08///^S X=$$NAPT^BQIULPT(BQIDFN);.09///^S X=DT;.11///^S X=DUZ"
D ^DIE
Q
;
HMS(BKMDFN,BQIEN,SUB,HFIL,HFLD) ; EP - Add patient to HMS register w/ status
; Taken from ACC^BKMVCD
; Replaced interactive messages with BMXSEC
;
; Input parameters:
; BKMDFN - patient ien
; BQIEN - record IENs
;
;
NEW BKMOK,BKMHIV,BKMIEN,BKMREG,BKMVUP
S BQIEN=$G(BQIEN,"")
I BQIEN'="" S BKMIENS=BQIEN
;
I BQIEN="" D
. S BKMHIV=$$HIVIEN^BKMIXX3()
. I BKMHIV="" S BMXSEC="RPC Call Failed: There is no HMS register defined." Q
. S BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN) ; BKMIEN and BKMREG used by BKMVAUD
. I BKMIEN="" S BKMIEN=$$ADDPAT^BKMVCD(BKMDFN) ; Create entry in iCare registry for pat
. I BKMIEN="" S BMXSEC="RPC Call Failed: An entry for the patient could not be created in the iCare registry." Q
. S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
. I BKMREG="" S BKMREG=$$ADDREG^BKMVCD(BKMIEN,BKMHIV) ; Create HMS register entry for pat
. I BKMREG="" S BMXSEC="RPC Call Failed: An entry for the patient could not be created in the HMS register." Q
. S BKMIENS=BKMREG_","_BKMIEN_","
. ;
. ; Add audit entry for the NEW rec
. ;D NEW^BKMVAUDN(BKMIEN,BKMREG,DUZ)
;
; If BQITYP is delete
I BQITYP="D" D Q
. NEW IENS
. I SUB="" D Q
.. S IENS=BQIEN,BQIUPD(FILE,IENS,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
.. I $D(ERROR)>0 S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) Q
.. S II=II+1,@DATA@(II)=1_U_$C(30)
. I SUB'="" D
.. D FIELD^DID(HFIL,HFLD,"","SPECIFIER","HARRAY")
.. S SBFIL=$G(HARRAY("SPECIFIER"))
.. S SBFIL=$$STRIP^XLFSTR(SBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.. I $$GET1^DIQ(SBFIL,BQIEN,$S(SBFIL=90451.03:4,SBFIL=90451.145:.04,1:3),"I")'=DUZ D Q
... S II=II+1,@DATA@(II)="-1^User is not owner, cannot edit"_$C(30)
.. S IENS=BQIEN,BQIUPD(SBFIL,BQIEN,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
.. ;S IENS=BQIEN,BQIUPD(SBFIL,IENS,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
.. I $D(ERROR)>0 S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) K ERROR Q
.. S II=II+1,@DATA@(II)=1_U_$C(30)
;
K BQIUPD
;
; Build multiple record
I SUB'="" D Q:$D(ERROR)>0
. K FDA,ERROR,BQQIEN
. I BQITYP="D" Q
. I BQITYP="A" S IENS="+1,"_BKMIENS
. I BQITYP="E" S IENS=BQIEN
. D SAV(.FDA,IENS)
. S SBFIL=$O(FDA("")) I SBFIL="" Q
. S FDA(SBFIL,IENS,$S(SBFIL=90451.03:4,SBFIL=90451.145:.04,1:3))=DUZ
. S FDA(SBFIL,IENS,$S(SBFIL=90451.03:5,SBFIL=90451.145:.05,1:4))=$$NOW^XLFDT()
. D UPDATE^DIE("","FDA","BQQIEN","ERROR")
. I $D(ERROR) S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) K ERROR Q
. K FDA,BQIDATA
. I $D(BQWP)>0 D
.. I BQITYP="A" S NWIENS=$G(BQQIEN(1))_","_BKMIENS
.. I BQITYP="E" S NWIENS=BKMIENS
.. D WP(NWIENS)
.. S BWDATA=$NA(BQIWP(SBFIL,NWIENS,20))
.. D WP^DIE(SBFIL,NWIENS,20,"",BWDATA,"ERROR")
. ;I $G(BKMSTAT)="" S BKMSTAT=$$GET1^DIQ(90451.01,BKMIENS,.5,"I")
. ;I $G(BKMSTAT)="" S BKMSTAT="A"
. I $D(ERROR) S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) K ERROR Q
;
I SUB'="" D
. S BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
. S BKMREG=$$BKMREG^BKMIXX3(BQIDFN)
. ;I $G(BKMIENS)'="" S BKMIENS=BKMREG_","_BKMIEN_","
;
I $L(BKMIENS,",")=4 D
. I $G(BKMSTAT)="" Q
. S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.02)=$$NOW^XLFDT()
. S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.025)=DUZ
. I $G(BKMSTAT)'="" S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.5)=$G(BKMSTAT)
. I $G(BQIUPD(90451.01,$P(BKMIENS,",",2,4),.5))="" K BQIUPD(90451.01,$P(BKMIENS,",",2,4),.5)
. S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.75)=$$NOW^XLFDT()
. S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.8)=DUZ
I $L(BKMIENS,",")<4 D
. I $G(BKMSTAT)="" Q
. S BQIUPD(90451.01,BKMIENS,.02)=$$NOW^XLFDT()
. S BQIUPD(90451.01,BKMIENS,.025)=DUZ
. I $G(BKMSTAT)'="" S BQIUPD(90451.01,BKMIENS,.5)=$G(BKMSTAT)
. I $G(BQIUPD(90451.01,BKMIENS,.5))="" K BQIUPD(90451.01,BKMIENS,.5)
. S BQIUPD(90451.01,BKMIENS,.75)=$$NOW^XLFDT()
. S BQIUPD(90451.01,BKMIENS,.8)=DUZ
;
K ERROR
D SAV(.BQIUPD,BKMIENS)
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
I $D(ERROR) D Q
. S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30)
;
I $D(BQIWP)>0 D
. S IENS=""
. F S IENS=$O(BQIWP(90451.01,IENS)) Q:IENS="" D
.. S BQFLD=""
.. F S BQFLD=$O(BQIWP(90451.01,IENS,BQFLD)) Q:BQFLD="" D
... S BWDATA=$NA(BQIWP(90451.01,IENS,BQFLD))
... D WP^DIE(90451.01,IENS,BQFLD,"",BWDATA,"ERROR")
I $D(ERROR)>0 S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) Q
;
S II=II+1,@DATA@(II)=1_U_$C(30)
; Make sure that HIV Case Manager added to DSPM
S BKMCMGR=$$GET1^DIQ(90451.01,BKMIENS,6.5,"I")
I BKMCMGR="" S BKMCMGR="@"
D AEDAP^BDPAPI(BKMDFN,BKMCMGR,"HIV CASE MANAGER",.RESULT)
S BKMPRV=$$GET1^DIQ(90451.01,BKMIENS,6,"I")
I BKMPRV="" S BKMPRV="@"
D AEDAP^BDPAPI(BKMDFN,BKMPRV,"HIV PROVIDER",.RESULT)
; Set the user last edited and date/time last edited
NEW BKMIEN,BKMREG,IENS
S BKMIEN=$P(BKMIENS,",",2),BKMREG=$P(BKMIENS,",",1)
I $G(BKMIEN)'="",$G(BKMREG)'="",$G(DUZ)'="" D
. ; Set the data via FileMan API
. K FDA
. S IENS="+1,"_BKMREG_","_BKMIEN_","
. S FDA(90451.05,IENS,.01)=$$NOW^XLFDT() ; DATE/TIME
. S FDA(90451.05,IENS,1)=DUZ ; EVENT USER (File 200)
. D UPDATE^DIE("","FDA","")
. K FDA,%DT,X,Y
;D POST^BKMVAUD ; End audit log
Q
BQIRGADD ;PRXM/HC/ALA-Save patient register data ; 16 Nov 2007 1:18 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
EN(DATA,BQIREG,BQIDFN,BQIEN,BQITYP,PARMS) ; EP - BQI SAVE REGISTER DATA
+1 ; Input parameters
+2 ; BQIREG - Register or sub-register name
+3 ; BQIDFN - Patient IEN
+4 ; BQIEN - Record IEN, if one was passed out to GUI
+5 ; BQITYP - What is to happen to the record (A=Add, E=Edit, D=Delete)
+6 ; PARMS - Parameters and their values
+7 ;
+8 NEW UID,II,ADD,BN,BQ,VFIEN,BQWP,PDATA,NAME,VALUE,PFIEN,PTYPE,RVIEN,FILE,FIELD
+9 NEW BQQI,BQIDATA,BQIASRG,SUB,RGDATA,XREF,SUBREG,GLBREF,GLBNOD,DA,DIK,BKMSTAT
+10 NEW BQFLD,BQJ,BWDATA,DFIELD,DFILE,NWIENS
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIRGADD",UID))
+13 KILL @DATA
+14 ;
+15 SET II=0
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGADD D UNWIND^%ZTER"
+17 SET @DATA@(II)="I00010RESULT^T01024MSG"_$CHAR(30)
+18 ;
+19 SET PARMS=$GET(PARMS,"")
+20 IF PARMS=""
Begin DoDot:1
+21 SET LIST=""
SET BN=""
+22 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+23 KILL PARMS
+24 SET PARMS=LIST
+25 KILL LIST
End DoDot:1
+26 ;
+27 IF $GET(PARMS)=""
IF BQITYP'="D"
QUIT
+28 IF BQIREG=""
SET BMXSEC="RPC Call Failed: Register not passed in."
QUIT
+29 SET VFIEN=$ORDER(^BQI(90506.3,"B",BQIREG,""))
+30 IF VFIEN=""
SET BMXSEC="RPC Call Failed: "_BQIREG_" does not exist."
QUIT
+31 KILL BQWP
+32 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+33 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+34 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+35 IF VALUE=""
SET VALUE="@"
+36 IF NAME="BKMWHOM"
QUIT
+37 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+38 SET PTYP=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
+39 IF PTYP="D"
IF VALUE'="@"
SET VALUE=$$DATE^BQIUL1(VALUE)
+40 ;I PTYP="T" S VALUE="`"_VALUE
+41 SET RVIEN=$ORDER(^BQI(90506.1,"B",NAME,""))
IF RVIEN=""
QUIT
+42 SET DFILE=$PIECE(^BQI(90506.1,RVIEN,0),U,5)
+43 SET DFIELD=$PIECE(^BQI(90506.1,RVIEN,0),U,6)
+44 IF PTYP="W"
Begin DoDot:2
+45 IF VALUE="@"
SET BQIDATA(DFILE,DFIELD)=VALUE
QUIT
+46 FOR BQQI=1:1
SET BQJ=$PIECE(VALUE,$CHAR(10),BQQI)
IF BQJ=""
QUIT
Begin DoDot:3
+47 SET BQWP(DFILE,DFIELD,BQQI)=BQJ
End DoDot:3
End DoDot:2
QUIT
+48 IF DFIELD'=".001"
SET BQIDATA(DFILE,DFIELD)=VALUE
End DoDot:1
+49 ;
+50 ; Check for register or subregister
+51 SET BQIASRG=""
+52 SET SUB=$PIECE(^BQI(90506.3,VFIEN,0),U,8)
+53 IF SUB'=""
Begin DoDot:1
+54 SET BQIREG=$PIECE(^BQI(90506.3,SUB,0),U,1)
+55 SET HFIL=$PIECE(^BQI(90506.3,SUB,0),U,10)
+56 SET HFLD=$PIECE(^BQI(90506.3,SUB,0),U,11)
+57 SET HFIL=$PIECE(^BQI(90506.3,VFIEN,0),U,10)
+58 SET HFLD=$PIECE(^BQI(90506.3,VFIEN,0),U,11)
End DoDot:1
+59 SET BQIASRG=$ORDER(^BQI(90507,"B",BQIREG,""))
+60 IF BQIASRG'=""
Begin DoDot:1
+61 SET RGDATA=^BQI(90507,BQIASRG,0)
+62 SET FILE=$PIECE(RGDATA,U,7)
SET XREF=$PIECE(RGDATA,U,6)
+63 SET ADD=$GET(^BQI(90507,BQIASRG,2))
+64 IF $GET(SUBREG)=""
SET SUBREG=$PIECE(RGDATA,U,9)
+65 SET GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
+66 SET GLBNOD=$$ROOT^DILFD(FILE,"",1)
+67 IF GLBNOD=""
QUIT
End DoDot:1
+68 ;
+69 ; If the register global doesn't exist, quit
+70 IF '$DATA(@GLBNOD@(0))
QUIT
+71 ;
+72 ; If the patient is not already in the register, add them else update their record
+73 SET BKMDFN=BQIDFN
SET HFIL=$GET(HFIL,"")
SET HFLD=$GET(HFLD,"")
+74 XECUTE ADD
+75 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
SAV(BQIUPD,IENS) ;EP - Set the data
+1 ;
+2 KILL BQIWP
+3 SET BQFIL=""
+4 FOR
SET BQFIL=$ORDER(BQIDATA(BQFIL))
IF BQFIL=""
QUIT
Begin DoDot:1
+5 SET BQFLD=""
+6 FOR
SET BQFLD=$ORDER(BQIDATA(BQFIL,BQFLD))
IF BQFLD=""
QUIT
Begin DoDot:2
+7 SET BQIUPD(BQFIL,IENS,BQFLD)=BQIDATA(BQFIL,BQFLD)
End DoDot:2
End DoDot:1
+8 ;
+9 IF $DATA(BQWP)
IF SUB=""
DO WP(IENS)
+10 QUIT
+11 ;
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 $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
WP(WIENS) ;EP - Set up word-processing array
+1 SET BQFIL=""
+2 FOR
SET BQFIL=$ORDER(BQWP(BQFIL))
IF BQFIL=""
QUIT
Begin DoDot:1
+3 SET BQFLD=""
+4 FOR
SET BQFLD=$ORDER(BQWP(BQFIL,BQFLD))
IF BQFLD=""
QUIT
Begin DoDot:2
+5 SET BQN=""
+6 FOR
SET BQN=$ORDER(BQWP(BQFIL,BQFLD,BQN))
IF BQN=""
QUIT
Begin DoDot:3
+7 SET BQIWP(BQFIL,WIENS,BQFLD,BQN)=BQWP(BQFIL,BQFLD,BQN)
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
AST(BQDFN) ;EP - Add patient to Asthma Register
+1 NEW DINUM,X,DIC,DLAYGO,DA,DR,DIE
+2 SET (DINUM,X)=BQDFN
SET DIC(0)="L"
SET DIC="^BATREG("
+3 SET DIC("DR")=".02///U"
SET DLAYGO=90181.01
SET DIADD=1
+4 KILL DO,DD
DO FILE^DICN
KILL DINUM,DLAYGO,DIADD
+5 SET DA=+Y
IF DA=-1
QUIT
+6 SET DIE=DIC
+7 SET DR=".05///^S X=$$LASTAV^BATU(BQIDFN,1);.06///^S X=$$LASTAV^BATU(BQIDFN,2);.08///^S X=$$NAPT^BQIULPT(BQIDFN);.09///^S X=DT;.11///^S X=DUZ"
+8 DO ^DIE
+9 QUIT
+10 ;
HMS(BKMDFN,BQIEN,SUB,HFIL,HFLD) ; EP - Add patient to HMS register w/ status
+1 ; Taken from ACC^BKMVCD
+2 ; Replaced interactive messages with BMXSEC
+3 ;
+4 ; Input parameters:
+5 ; BKMDFN - patient ien
+6 ; BQIEN - record IENs
+7 ;
+8 ;
+9 NEW BKMOK,BKMHIV,BKMIEN,BKMREG,BKMVUP
+10 SET BQIEN=$GET(BQIEN,"")
+11 IF BQIEN'=""
SET BKMIENS=BQIEN
+12 ;
+13 IF BQIEN=""
Begin DoDot:1
+14 SET BKMHIV=$$HIVIEN^BKMIXX3()
+15 IF BKMHIV=""
SET BMXSEC="RPC Call Failed: There is no HMS register defined."
QUIT
+16 ; BKMIEN and BKMREG used by BKMVAUD
SET BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
+17 ; Create entry in iCare registry for pat
IF BKMIEN=""
SET BKMIEN=$$ADDPAT^BKMVCD(BKMDFN)
+18 IF BKMIEN=""
SET BMXSEC="RPC Call Failed: An entry for the patient could not be created in the iCare registry."
QUIT
+19 SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
+20 ; Create HMS register entry for pat
IF BKMREG=""
SET BKMREG=$$ADDREG^BKMVCD(BKMIEN,BKMHIV)
+21 IF BKMREG=""
SET BMXSEC="RPC Call Failed: An entry for the patient could not be created in the HMS register."
QUIT
+22 SET BKMIENS=BKMREG_","_BKMIEN_","
+23 ;
+24 ; Add audit entry for the NEW rec
+25 ;D NEW^BKMVAUDN(BKMIEN,BKMREG,DUZ)
End DoDot:1
+26 ;
+27 ; If BQITYP is delete
+28 IF BQITYP="D"
Begin DoDot:1
+29 NEW IENS
+30 IF SUB=""
Begin DoDot:2
+31 SET IENS=BQIEN
SET BQIUPD(FILE,IENS,.01)="@"
DO FILE^DIE("","BQIUPD","ERROR")
+32 IF $DATA(ERROR)>0
SET II=II+1
SET @DATA@(II)=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
QUIT
+33 SET II=II+1
SET @DATA@(II)=1_U_$CHAR(30)
End DoDot:2
QUIT
+34 IF SUB'=""
Begin DoDot:2
+35 DO FIELD^DID(HFIL,HFLD,"","SPECIFIER","HARRAY")
+36 SET SBFIL=$GET(HARRAY("SPECIFIER"))
+37 SET SBFIL=$$STRIP^XLFSTR(SBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+38 IF $$GET1^DIQ(SBFIL,BQIEN,$SELECT(SBFIL=90451.03:4,SBFIL=90451.145:.04,1:3),"I")'=DUZ
Begin DoDot:3
+39 SET II=II+1
SET @DATA@(II)="-1^User is not owner, cannot edit"_$CHAR(30)
End DoDot:3
QUIT
+40 SET IENS=BQIEN
SET BQIUPD(SBFIL,BQIEN,.01)="@"
DO FILE^DIE("","BQIUPD","ERROR")
+41 ;S IENS=BQIEN,BQIUPD(SBFIL,IENS,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
+42 IF $DATA(ERROR)>0
SET II=II+1
SET @DATA@(II)=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
KILL ERROR
QUIT
+43 SET II=II+1
SET @DATA@(II)=1_U_$CHAR(30)
End DoDot:2
End DoDot:1
QUIT
+44 ;
+45 KILL BQIUPD
+46 ;
+47 ; Build multiple record
+48 IF SUB'=""
Begin DoDot:1
+49 KILL FDA,ERROR,BQQIEN
+50 IF BQITYP="D"
QUIT
+51 IF BQITYP="A"
SET IENS="+1,"_BKMIENS
+52 IF BQITYP="E"
SET IENS=BQIEN
+53 DO SAV(.FDA,IENS)
+54 SET SBFIL=$ORDER(FDA(""))
IF SBFIL=""
QUIT
+55 SET FDA(SBFIL,IENS,$SELECT(SBFIL=90451.03:4,SBFIL=90451.145:.04,1:3))=DUZ
+56 SET FDA(SBFIL,IENS,$SELECT(SBFIL=90451.03:5,SBFIL=90451.145:.05,1:4))=$$NOW^XLFDT()
+57 DO UPDATE^DIE("","FDA","BQQIEN","ERROR")
+58 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
KILL ERROR
QUIT
+59 KILL FDA,BQIDATA
+60 IF $DATA(BQWP)>0
Begin DoDot:2
+61 IF BQITYP="A"
SET NWIENS=$GET(BQQIEN(1))_","_BKMIENS
+62 IF BQITYP="E"
SET NWIENS=BKMIENS
+63 DO WP(NWIENS)
+64 SET BWDATA=$NAME(BQIWP(SBFIL,NWIENS,20))
+65 DO WP^DIE(SBFIL,NWIENS,20,"",BWDATA,"ERROR")
End DoDot:2
+66 ;I $G(BKMSTAT)="" S BKMSTAT=$$GET1^DIQ(90451.01,BKMIENS,.5,"I")
+67 ;I $G(BKMSTAT)="" S BKMSTAT="A"
+68 IF $DATA(ERROR)
SET II=II+1
SET @DATA@(II)=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
KILL ERROR
QUIT
End DoDot:1
IF $DATA(ERROR)>0
QUIT
+69 ;
+70 IF SUB'=""
Begin DoDot:1
+71 SET BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
+72 SET BKMREG=$$BKMREG^BKMIXX3(BQIDFN)
+73 ;I $G(BKMIENS)'="" S BKMIENS=BKMREG_","_BKMIEN_","
End DoDot:1
+74 ;
+75 IF $LENGTH(BKMIENS,",")=4
Begin DoDot:1
+76 IF $GET(BKMSTAT)=""
QUIT
+77 SET BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.02)=$$NOW^XLFDT()
+78 SET BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.025)=DUZ
+79 IF $GET(BKMSTAT)'=""
SET BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.5)=$GET(BKMSTAT)
+80 IF $GET(BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.5))=""
KILL BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.5)
+81 SET BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.75)=$$NOW^XLFDT()
+82 SET BQIUPD(90451.01,$PIECE(BKMIENS,",",2,4),.8)=DUZ
End DoDot:1
+83 IF $LENGTH(BKMIENS,",")<4
Begin DoDot:1
+84 IF $GET(BKMSTAT)=""
QUIT
+85 SET BQIUPD(90451.01,BKMIENS,.02)=$$NOW^XLFDT()
+86 SET BQIUPD(90451.01,BKMIENS,.025)=DUZ
+87 IF $GET(BKMSTAT)'=""
SET BQIUPD(90451.01,BKMIENS,.5)=$GET(BKMSTAT)
+88 IF $GET(BQIUPD(90451.01,BKMIENS,.5))=""
KILL BQIUPD(90451.01,BKMIENS,.5)
+89 SET BQIUPD(90451.01,BKMIENS,.75)=$$NOW^XLFDT()
+90 SET BQIUPD(90451.01,BKMIENS,.8)=DUZ
End DoDot:1
+91 ;
+92 KILL ERROR
+93 DO SAV(.BQIUPD,BKMIENS)
+94 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+95 KILL BQIUPD
+96 ;
+97 IF $DATA(ERROR)
Begin DoDot:1
+98 SET II=II+1
SET @DATA@(II)=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
End DoDot:1
QUIT
+99 ;
+100 IF $DATA(BQIWP)>0
Begin DoDot:1
+101 SET IENS=""
+102 FOR
SET IENS=$ORDER(BQIWP(90451.01,IENS))
IF IENS=""
QUIT
Begin DoDot:2
+103 SET BQFLD=""
+104 FOR
SET BQFLD=$ORDER(BQIWP(90451.01,IENS,BQFLD))
IF BQFLD=""
QUIT
Begin DoDot:3
+105 SET BWDATA=$NAME(BQIWP(90451.01,IENS,BQFLD))
+106 DO WP^DIE(90451.01,IENS,BQFLD,"",BWDATA,"ERROR")
End DoDot:3
End DoDot:2
End DoDot:1
+107 IF $DATA(ERROR)>0
SET II=II+1
SET @DATA@(II)=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))_$CHAR(30)
QUIT
+108 ;
+109 SET II=II+1
SET @DATA@(II)=1_U_$CHAR(30)
+110 ; Make sure that HIV Case Manager added to DSPM
+111 SET BKMCMGR=$$GET1^DIQ(90451.01,BKMIENS,6.5,"I")
+112 IF BKMCMGR=""
SET BKMCMGR="@"
+113 DO AEDAP^BDPAPI(BKMDFN,BKMCMGR,"HIV CASE MANAGER",.RESULT)
+114 SET BKMPRV=$$GET1^DIQ(90451.01,BKMIENS,6,"I")
+115 IF BKMPRV=""
SET BKMPRV="@"
+116 DO AEDAP^BDPAPI(BKMDFN,BKMPRV,"HIV PROVIDER",.RESULT)
+117 ; Set the user last edited and date/time last edited
+118 NEW BKMIEN,BKMREG,IENS
+119 SET BKMIEN=$PIECE(BKMIENS,",",2)
SET BKMREG=$PIECE(BKMIENS,",",1)
+120 IF $GET(BKMIEN)'=""
IF $GET(BKMREG)'=""
IF $GET(DUZ)'=""
Begin DoDot:1
+121 ; Set the data via FileMan API
+122 KILL FDA
+123 SET IENS="+1,"_BKMREG_","_BKMIEN_","
+124 ; DATE/TIME
SET FDA(90451.05,IENS,.01)=$$NOW^XLFDT()
+125 ; EVENT USER (File 200)
SET FDA(90451.05,IENS,1)=DUZ
+126 DO UPDATE^DIE("","FDA","")
+127 KILL FDA,%DT,X,Y
End DoDot:1
+128 ;D POST^BKMVAUD ; End audit log
+129 QUIT
