BQIRGACM ;HCSD/HSD/ALA-Register Columns ; 19 Feb 2016 9:08 AM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
;
;
DXN(BQIDFN,SUBREG) ;EP - Diagnoses
NEW ACMIEN,VLU,TEXT
S ACMIEN=$O(^ACM(41.1,"B",SUBREG,""))
S VLU="",TEXT=""
F S VLU=$O(^ACM(44,"AC",ACMIEN,BQIDFN,VLU)) Q:VLU="" D
. S TEXT=TEXT_$P(^ACM(44.1,VLU,0),U,1)_$C(10)_$C(13)
Q $$TKO^BQIUL1(TEXT,$C(10)_$C(13))
;
COMP(BQIDFN,SUBREG) ; EP - Complications
NEW ACMIEN,VLU,TEXT
S ACMIEN=$O(^ACM(41.1,"B",SUBREG,""))
S VLU="",TEXT=""
F S VLU=$O(^ACM(42,"AC",ACMIEN,BQIDFN,VLU)) Q:VLU="" D
. S TEXT=TEXT_$P(^ACM(42.1,VLU,0),U,1)_$C(10)_$C(13)
Q $$TKO^BQIUL1(TEXT,$C(10)_$C(13))
;
ADD(DATA,NAME,DESC) ;EP -- BQI CREATE REGISTER
NEW UID,X,BQII,PLID,TMP,REGIEN,MSG
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP(UID,"BQIRGCR")) K @DATA
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGACM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Check that REGISTER name is unique
S BQII=0,RESULT=1,MSG="",RGIEN=""
S @DATA@(BQII)="I00010RESULT^I00010REG_IEN^T00030MSG"_$C(30)
;
I NAME'="" D G DONE:$G(MSG)'=""
. N DA,IENS,ERROR
. S IENS=$$IENS^DILF(.DA)
. S TMP=$$FIND1^DIC(9002241.1,"","X",NAME,"","","ERROR")
. I TMP=0 Q ; Name not currently in use
. S MSG="Register name already exists"
. Q
;
; Create record
S DIC(0)="LMQZ",DLAYGO=9002241.1
S DIC="^ACM(41.1,",X=NAME
D ^DIC S DA=+Y
I DA=-1 K DO,DD D FILE^DICN S DA=+Y
I DA=-1 S MSG="Unable to create register" G DONE
S UPD(9002241.1,DA_",",1)=DT,UP(9002241.1,DA_",",3.5)=DUZ,UPD(9002241.1,DA_",",9)=DESC
S UPD(9002241.1,DA_",",5)=0,UPD(9002241.1,DA_",",6)=0,UPD(9002241.1,DA_",",7)=0
S UPD(9002241.1,DA_",",100)=1,REGIEN=DA
D FILE^DIE("","UPD","ERROR")
I '$D(^ACM(41.1,DA,"AU",0)) S ^ACM(41.1,DA,"AU",0)="^9002241.12P^^"
S (X,DINUM)=DUZ,DA(1)=DA,DIC="^ACM(41.1,"_DA(1)_",""AU"","
K DO,DD D FILE^DICN
;
DONE ; -- exit code
I $G(MSG)'="" S RESULT=-1
S BQII=BQII+1,@DATA@(BQII)=RESULT_U_$G(REGIEN)_U_MSG_$C(30)
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
APAT(DATA,REGIEN,PLIST) ; EP -- BQI ADD PATIENTS TO REGISTER
NEW UID,II,X,BN,LIST,BQI,DFN,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRGAPT",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGACM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT"_$C(30),RESULT=-1
I $D(PLIST)>0 D
. I $D(PLIST)>1 D
.. S LIST="",BN=""
.. F S BN=$O(PLIST(BN)) Q:BN="" S LIST=LIST_PLIST(BN)
.. K PLIST S PLIST=LIST
. F BQI=1:1 S DFN=$P(PLIST,$C(28),BQI) Q:DFN="" D
.. S X=REGIEN,DIC="^ACM(41,",DIC(0)="L"
.. K DD,DO D FILE^DICN K DIC,DIE,DR,DA
.. S ACMPTNO=+Y
.. S UPD(9002241,ACMPTNO_",",.02)=DFN,UPD(9002241,ACMPTNO_",",1)="A"
.. S UPD(9002241,ACMPTNO_",",2)=DT,UPD(9002241,ACMPTNO_",",4)=DT
. D FILE^DIE("","UPD","ERROR") I '$D(ERROR) S RESULT=1
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
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
BQIRGACM ;HCSD/HSD/ALA-Register Columns ; 19 Feb 2016 9:08 AM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 ;
+3 ;
DXN(BQIDFN,SUBREG) ;EP - Diagnoses
+1 NEW ACMIEN,VLU,TEXT
+2 SET ACMIEN=$ORDER(^ACM(41.1,"B",SUBREG,""))
+3 SET VLU=""
SET TEXT=""
+4 FOR
SET VLU=$ORDER(^ACM(44,"AC",ACMIEN,BQIDFN,VLU))
IF VLU=""
QUIT
Begin DoDot:1
+5 SET TEXT=TEXT_$PIECE(^ACM(44.1,VLU,0),U,1)_$CHAR(10)_$CHAR(13)
End DoDot:1
+6 QUIT $$TKO^BQIUL1(TEXT,$CHAR(10)_$CHAR(13))
+7 ;
COMP(BQIDFN,SUBREG) ; EP - Complications
+1 NEW ACMIEN,VLU,TEXT
+2 SET ACMIEN=$ORDER(^ACM(41.1,"B",SUBREG,""))
+3 SET VLU=""
SET TEXT=""
+4 FOR
SET VLU=$ORDER(^ACM(42,"AC",ACMIEN,BQIDFN,VLU))
IF VLU=""
QUIT
Begin DoDot:1
+5 SET TEXT=TEXT_$PIECE(^ACM(42.1,VLU,0),U,1)_$CHAR(10)_$CHAR(13)
End DoDot:1
+6 QUIT $$TKO^BQIUL1(TEXT,$CHAR(10)_$CHAR(13))
+7 ;
ADD(DATA,NAME,DESC) ;EP -- BQI CREATE REGISTER
+1 NEW UID,X,BQII,PLID,TMP,REGIEN,MSG
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP(UID,"BQIRGCR"))
KILL @DATA
+4 ;
+5 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGACM D UNWIND^%ZTER"
+6 ;
+7 ; Check that REGISTER name is unique
+8 SET BQII=0
SET RESULT=1
SET MSG=""
SET RGIEN=""
+9 SET @DATA@(BQII)="I00010RESULT^I00010REG_IEN^T00030MSG"_$CHAR(30)
+10 ;
+11 IF NAME'=""
Begin DoDot:1
+12 NEW DA,IENS,ERROR
+13 SET IENS=$$IENS^DILF(.DA)
+14 SET TMP=$$FIND1^DIC(9002241.1,"","X",NAME,"","","ERROR")
+15 ; Name not currently in use
IF TMP=0
QUIT
+16 SET MSG="Register name already exists"
+17 QUIT
End DoDot:1
IF $GET(MSG)'=""
GOTO DONE
+18 ;
+19 ; Create record
+20 SET DIC(0)="LMQZ"
SET DLAYGO=9002241.1
+21 SET DIC="^ACM(41.1,"
SET X=NAME
+22 DO ^DIC
SET DA=+Y
+23 IF DA=-1
KILL DO,DD
DO FILE^DICN
SET DA=+Y
+24 IF DA=-1
SET MSG="Unable to create register"
GOTO DONE
+25 SET UPD(9002241.1,DA_",",1)=DT
SET UP(9002241.1,DA_",",3.5)=DUZ
SET UPD(9002241.1,DA_",",9)=DESC
+26 SET UPD(9002241.1,DA_",",5)=0
SET UPD(9002241.1,DA_",",6)=0
SET UPD(9002241.1,DA_",",7)=0
+27 SET UPD(9002241.1,DA_",",100)=1
SET REGIEN=DA
+28 DO FILE^DIE("","UPD","ERROR")
+29 IF '$DATA(^ACM(41.1,DA,"AU",0))
SET ^ACM(41.1,DA,"AU",0)="^9002241.12P^^"
+30 SET (X,DINUM)=DUZ
SET DA(1)=DA
SET DIC="^ACM(41.1,"_DA(1)_",""AU"","
+31 KILL DO,DD
DO FILE^DICN
+32 ;
DONE ; -- exit code
+1 IF $GET(MSG)'=""
SET RESULT=-1
+2 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_U_$GET(REGIEN)_U_MSG_$CHAR(30)
+3 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+4 QUIT
+5 ;
APAT(DATA,REGIEN,PLIST) ; EP -- BQI ADD PATIENTS TO REGISTER
+1 NEW UID,II,X,BN,LIST,BQI,DFN,RESULT
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIRGAPT",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGACM D UNWIND^%ZTER"
+8 ;
+9 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
SET RESULT=-1
+10 IF $DATA(PLIST)>0
Begin DoDot:1
+11 IF $DATA(PLIST)>1
Begin DoDot:2
+12 SET LIST=""
SET BN=""
+13 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+14 KILL PLIST
SET PLIST=LIST
End DoDot:2
+15 FOR BQI=1:1
SET DFN=$PIECE(PLIST,$CHAR(28),BQI)
IF DFN=""
QUIT
Begin DoDot:2
+16 SET X=REGIEN
SET DIC="^ACM(41,"
SET DIC(0)="L"
+17 KILL DD,DO
DO FILE^DICN
KILL DIC,DIE,DR,DA
+18 SET ACMPTNO=+Y
+19 SET UPD(9002241,ACMPTNO_",",.02)=DFN
SET UPD(9002241,ACMPTNO_",",1)="A"
+20 SET UPD(9002241,ACMPTNO_",",2)=DT
SET UPD(9002241,ACMPTNO_",",4)=DT
End DoDot:2
+21 DO FILE^DIE("","UPD","ERROR")
IF '$DATA(ERROR)
SET RESULT=1
End DoDot:1
+22 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+23 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+24 QUIT
+25 ;
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
