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

BQIRGADD.m

Go to the documentation of this file.
  1. BQIRGADD ;PRXM/HC/ALA-Save patient register data ; 16 Nov 2007 1:18 PM
  1. ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
  1. ;
  1. EN(DATA,BQIREG,BQIDFN,BQIEN,BQITYP,PARMS) ; EP - BQI SAVE REGISTER DATA
  1. ; Input parameters
  1. ; BQIREG - Register or sub-register name
  1. ; BQIDFN - Patient IEN
  1. ; BQIEN - Record IEN, if one was passed out to GUI
  1. ; BQITYP - What is to happen to the record (A=Add, E=Edit, D=Delete)
  1. ; PARMS - Parameters and their values
  1. ;
  1. NEW UID,II,ADD,BN,BQ,VFIEN,BQWP,PDATA,NAME,VALUE,PFIEN,PTYPE,RVIEN,FILE,FIELD
  1. NEW BQQI,BQIDATA,BQIASRG,SUB,RGDATA,XREF,SUBREG,GLBREF,GLBNOD,DA,DIK,BKMSTAT
  1. NEW BQFLD,BQJ,BWDATA,DFIELD,DFILE,NWIENS
  1. S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1. S DATA=$NA(^TMP("BQIRGADD",UID))
  1. K @DATA
  1. ;
  1. S II=0
  1. NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGADD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1. S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
  1. ;
  1. S PARMS=$G(PARMS,"")
  1. I PARMS="" D
  1. . S LIST="",BN=""
  1. . F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
  1. . K PARMS
  1. . S PARMS=LIST
  1. . K LIST
  1. ;
  1. I $G(PARMS)="",BQITYP'="D" Q
  1. I BQIREG="" S BMXSEC="RPC Call Failed: Register not passed in." Q
  1. S VFIEN=$O(^BQI(90506.3,"B",BQIREG,""))
  1. I VFIEN="" S BMXSEC="RPC Call Failed: "_BQIREG_" does not exist." Q
  1. K BQWP
  1. F BQ=1:1:$L(PARMS,$C(28)) D
  1. . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1. . S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
  1. . I VALUE="" S VALUE="@"
  1. . I NAME="BKMWHOM" Q
  1. . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
  1. . S PTYP=$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
  1. . I PTYP="D",VALUE'="@" S VALUE=$$DATE^BQIUL1(VALUE)
  1. . ;I PTYP="T" S VALUE="`"_VALUE
  1. . S RVIEN=$O(^BQI(90506.1,"B",NAME,"")) I RVIEN="" Q
  1. . S DFILE=$P(^BQI(90506.1,RVIEN,0),U,5)
  1. . S DFIELD=$P(^BQI(90506.1,RVIEN,0),U,6)
  1. . I PTYP="W" D Q
  1. .. I VALUE="@" S BQIDATA(DFILE,DFIELD)=VALUE Q
  1. .. F BQQI=1:1 S BQJ=$P(VALUE,$C(10),BQQI) Q:BQJ="" D
  1. ... S BQWP(DFILE,DFIELD,BQQI)=BQJ
  1. . I DFIELD'=".001" S BQIDATA(DFILE,DFIELD)=VALUE
  1. ;
  1. ; Check for register or subregister
  1. S BQIASRG=""
  1. S SUB=$P(^BQI(90506.3,VFIEN,0),U,8)
  1. I SUB'="" D
  1. . S BQIREG=$P(^BQI(90506.3,SUB,0),U,1)
  1. . S HFIL=$P(^BQI(90506.3,SUB,0),U,10)
  1. . S HFLD=$P(^BQI(90506.3,SUB,0),U,11)
  1. . S HFIL=$P(^BQI(90506.3,VFIEN,0),U,10)
  1. . S HFLD=$P(^BQI(90506.3,VFIEN,0),U,11)
  1. S BQIASRG=$O(^BQI(90507,"B",BQIREG,""))
  1. I BQIASRG'="" D
  1. . S RGDATA=^BQI(90507,BQIASRG,0)
  1. . S FILE=$P(RGDATA,U,7),XREF=$P(RGDATA,U,6)
  1. . S ADD=$G(^BQI(90507,BQIASRG,2))
  1. . I $G(SUBREG)="" S SUBREG=$P(RGDATA,U,9)
  1. . S GLBREF=$$ROOT^DILFD(FILE,"")_XREF_")"
  1. . S GLBNOD=$$ROOT^DILFD(FILE,"",1)
  1. . I GLBNOD="" Q
  1. ;
  1. ; If the register global doesn't exist, quit
  1. I '$D(@GLBNOD@(0)) Q
  1. ;
  1. ; If the patient is not already in the register, add them else update their record
  1. S BKMDFN=BQIDFN,HFIL=$G(HFIL,""),HFLD=$G(HFLD,"")
  1. X ADD
  1. ;
  1. DONE ;
  1. S II=II+1,@DATA@(II)=$C(31)
  1. Q
  1. ;
  1. SAV(BQIUPD,IENS) ;EP - Set the data
  1. ;
  1. K BQIWP
  1. S BQFIL=""
  1. F S BQFIL=$O(BQIDATA(BQFIL)) Q:BQFIL="" D
  1. . S BQFLD=""
  1. . F S BQFLD=$O(BQIDATA(BQFIL,BQFLD)) Q:BQFLD="" D
  1. .. S BQIUPD(BQFIL,IENS,BQFLD)=BQIDATA(BQFIL,BQFLD)
  1. ;
  1. I $D(BQWP),SUB="" D WP(IENS)
  1. Q
  1. ;
  1. ERR ;
  1. D ^%ZTER
  1. NEW Y,ERRDTM
  1. S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1. S BMXSEC="Recording that an error occurred at "_ERRDTM
  1. I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1. Q
  1. ;
  1. WP(WIENS) ;EP - Set up word-processing array
  1. S BQFIL=""
  1. F S BQFIL=$O(BQWP(BQFIL)) Q:BQFIL="" D
  1. . S BQFLD=""
  1. . F S BQFLD=$O(BQWP(BQFIL,BQFLD)) Q:BQFLD="" D
  1. .. S BQN=""
  1. .. F S BQN=$O(BQWP(BQFIL,BQFLD,BQN)) Q:BQN="" D
  1. ... S BQIWP(BQFIL,WIENS,BQFLD,BQN)=BQWP(BQFIL,BQFLD,BQN)
  1. Q
  1. ;
  1. AST(BQDFN) ;EP - Add patient to Asthma Register
  1. NEW DINUM,X,DIC,DLAYGO,DA,DR,DIE
  1. S (DINUM,X)=BQDFN,DIC(0)="L",DIC="^BATREG("
  1. S DIC("DR")=".02///U",DLAYGO=90181.01,DIADD=1
  1. K DO,DD D FILE^DICN K DINUM,DLAYGO,DIADD
  1. S DA=+Y I DA=-1 Q
  1. S DIE=DIC
  1. 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"
  1. D ^DIE
  1. Q
  1. ;
  1. HMS(BKMDFN,BQIEN,SUB,HFIL,HFLD) ; EP - Add patient to HMS register w/ status
  1. ; Taken from ACC^BKMVCD
  1. ; Replaced interactive messages with BMXSEC
  1. ;
  1. ; Input parameters:
  1. ; BKMDFN - patient ien
  1. ; BQIEN - record IENs
  1. ;
  1. ;
  1. NEW BKMOK,BKMHIV,BKMIEN,BKMREG,BKMVUP
  1. S BQIEN=$G(BQIEN,"")
  1. I BQIEN'="" S BKMIENS=BQIEN
  1. ;
  1. I BQIEN="" D
  1. . S BKMHIV=$$HIVIEN^BKMIXX3()
  1. . I BKMHIV="" S BMXSEC="RPC Call Failed: There is no HMS register defined." Q
  1. . S BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN) ; BKMIEN and BKMREG used by BKMVAUD
  1. . I BKMIEN="" S BKMIEN=$$ADDPAT^BKMVCD(BKMDFN) ; Create entry in iCare registry for pat
  1. . I BKMIEN="" S BMXSEC="RPC Call Failed: An entry for the patient could not be created in the iCare registry." Q
  1. . S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)
  1. . I BKMREG="" S BKMREG=$$ADDREG^BKMVCD(BKMIEN,BKMHIV) ; Create HMS register entry for pat
  1. . I BKMREG="" S BMXSEC="RPC Call Failed: An entry for the patient could not be created in the HMS register." Q
  1. . S BKMIENS=BKMREG_","_BKMIEN_","
  1. . ;
  1. . ; Add audit entry for the NEW rec
  1. . ;D NEW^BKMVAUDN(BKMIEN,BKMREG,DUZ)
  1. ;
  1. ; If BQITYP is delete
  1. I BQITYP="D" D Q
  1. . NEW IENS
  1. . I SUB="" D Q
  1. .. S IENS=BQIEN,BQIUPD(FILE,IENS,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
  1. .. I $D(ERROR)>0 S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) Q
  1. .. S II=II+1,@DATA@(II)=1_U_$C(30)
  1. . I SUB'="" D
  1. .. D FIELD^DID(HFIL,HFLD,"","SPECIFIER","HARRAY")
  1. .. S SBFIL=$G(HARRAY("SPECIFIER"))
  1. .. S SBFIL=$$STRIP^XLFSTR(SBFIL,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. .. I $$GET1^DIQ(SBFIL,BQIEN,$S(SBFIL=90451.03:4,SBFIL=90451.145:.04,1:3),"I")'=DUZ D Q
  1. ... S II=II+1,@DATA@(II)="-1^User is not owner, cannot edit"_$C(30)
  1. .. S IENS=BQIEN,BQIUPD(SBFIL,BQIEN,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
  1. .. ;S IENS=BQIEN,BQIUPD(SBFIL,IENS,.01)="@" D FILE^DIE("","BQIUPD","ERROR")
  1. .. I $D(ERROR)>0 S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) K ERROR Q
  1. .. S II=II+1,@DATA@(II)=1_U_$C(30)
  1. ;
  1. K BQIUPD
  1. ;
  1. ; Build multiple record
  1. I SUB'="" D Q:$D(ERROR)>0
  1. . K FDA,ERROR,BQQIEN
  1. . I BQITYP="D" Q
  1. . I BQITYP="A" S IENS="+1,"_BKMIENS
  1. . I BQITYP="E" S IENS=BQIEN
  1. . D SAV(.FDA,IENS)
  1. . S SBFIL=$O(FDA("")) I SBFIL="" Q
  1. . S FDA(SBFIL,IENS,$S(SBFIL=90451.03:4,SBFIL=90451.145:.04,1:3))=DUZ
  1. . S FDA(SBFIL,IENS,$S(SBFIL=90451.03:5,SBFIL=90451.145:.05,1:4))=$$NOW^XLFDT()
  1. . D UPDATE^DIE("","FDA","BQQIEN","ERROR")
  1. . I $D(ERROR) S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) K ERROR Q
  1. . K FDA,BQIDATA
  1. . I $D(BQWP)>0 D
  1. .. I BQITYP="A" S NWIENS=$G(BQQIEN(1))_","_BKMIENS
  1. .. I BQITYP="E" S NWIENS=BKMIENS
  1. .. D WP(NWIENS)
  1. .. S BWDATA=$NA(BQIWP(SBFIL,NWIENS,20))
  1. .. D WP^DIE(SBFIL,NWIENS,20,"",BWDATA,"ERROR")
  1. . ;I $G(BKMSTAT)="" S BKMSTAT=$$GET1^DIQ(90451.01,BKMIENS,.5,"I")
  1. . ;I $G(BKMSTAT)="" S BKMSTAT="A"
  1. . I $D(ERROR) S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) K ERROR Q
  1. ;
  1. I SUB'="" D
  1. . S BKMIEN=$$BKMIEN^BKMIXX3(BKMDFN)
  1. . S BKMREG=$$BKMREG^BKMIXX3(BQIDFN)
  1. . ;I $G(BKMIENS)'="" S BKMIENS=BKMREG_","_BKMIEN_","
  1. ;
  1. I $L(BKMIENS,",")=4 D
  1. . I $G(BKMSTAT)="" Q
  1. . S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.02)=$$NOW^XLFDT()
  1. . S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.025)=DUZ
  1. . I $G(BKMSTAT)'="" S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.5)=$G(BKMSTAT)
  1. . I $G(BQIUPD(90451.01,$P(BKMIENS,",",2,4),.5))="" K BQIUPD(90451.01,$P(BKMIENS,",",2,4),.5)
  1. . S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.75)=$$NOW^XLFDT()
  1. . S BQIUPD(90451.01,$P(BKMIENS,",",2,4),.8)=DUZ
  1. I $L(BKMIENS,",")<4 D
  1. . I $G(BKMSTAT)="" Q
  1. . S BQIUPD(90451.01,BKMIENS,.02)=$$NOW^XLFDT()
  1. . S BQIUPD(90451.01,BKMIENS,.025)=DUZ
  1. . I $G(BKMSTAT)'="" S BQIUPD(90451.01,BKMIENS,.5)=$G(BKMSTAT)
  1. . I $G(BQIUPD(90451.01,BKMIENS,.5))="" K BQIUPD(90451.01,BKMIENS,.5)
  1. . S BQIUPD(90451.01,BKMIENS,.75)=$$NOW^XLFDT()
  1. . S BQIUPD(90451.01,BKMIENS,.8)=DUZ
  1. ;
  1. K ERROR
  1. D SAV(.BQIUPD,BKMIENS)
  1. I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1. K BQIUPD
  1. ;
  1. I $D(ERROR) D Q
  1. . S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30)
  1. ;
  1. I $D(BQIWP)>0 D
  1. . S IENS=""
  1. . F S IENS=$O(BQIWP(90451.01,IENS)) Q:IENS="" D
  1. .. S BQFLD=""
  1. .. F S BQFLD=$O(BQIWP(90451.01,IENS,BQFLD)) Q:BQFLD="" D
  1. ... S BWDATA=$NA(BQIWP(90451.01,IENS,BQFLD))
  1. ... D WP^DIE(90451.01,IENS,BQFLD,"",BWDATA,"ERROR")
  1. I $D(ERROR)>0 S II=II+1,@DATA@(II)=-1_U_$G(ERROR("DIERR",1,"TEXT",1))_$C(30) Q
  1. ;
  1. S II=II+1,@DATA@(II)=1_U_$C(30)
  1. ; Make sure that HIV Case Manager added to DSPM
  1. S BKMCMGR=$$GET1^DIQ(90451.01,BKMIENS,6.5,"I")
  1. I BKMCMGR="" S BKMCMGR="@"
  1. D AEDAP^BDPAPI(BKMDFN,BKMCMGR,"HIV CASE MANAGER",.RESULT)
  1. S BKMPRV=$$GET1^DIQ(90451.01,BKMIENS,6,"I")
  1. I BKMPRV="" S BKMPRV="@"
  1. D AEDAP^BDPAPI(BKMDFN,BKMPRV,"HIV PROVIDER",.RESULT)
  1. ; Set the user last edited and date/time last edited
  1. NEW BKMIEN,BKMREG,IENS
  1. S BKMIEN=$P(BKMIENS,",",2),BKMREG=$P(BKMIENS,",",1)
  1. I $G(BKMIEN)'="",$G(BKMREG)'="",$G(DUZ)'="" D
  1. . ; Set the data via FileMan API
  1. . K FDA
  1. . S IENS="+1,"_BKMREG_","_BKMIEN_","
  1. . S FDA(90451.05,IENS,.01)=$$NOW^XLFDT() ; DATE/TIME
  1. . S FDA(90451.05,IENS,1)=DUZ ; EVENT USER (File 200)
  1. . D UPDATE^DIE("","FDA","")
  1. . K FDA,%DT,X,Y
  1. ;D POST^BKMVAUD ; End audit log
  1. Q