- 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