BQIPTRPF ;VNGT/HS/ALA-Reproductive Factors Grid RPC ; 25 Jan 2010 1:26 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
EN(DATA,DFN) ; EP -- BQI REPRODUCTIVE FACTORS GRID
;
;Description - all the reproductive factors that a patient has in grid format
;
;Input
; DFN - Patient internal entry number
;
NEW UID,II,VFIEN,HEADR,VALUE,N,CODE,VAL,IEN,HDR,SEX,AGE
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTRPF",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S SEX=$$GET1^DIQ(2,DFN_",",.02,"I"),AGE=$$AGE^BQIAGE(DFN)
I SEX'="F" S BMXSEC="RPC Failed: Patient is not Female" Q
;
D REP^BQIPTRP1(.NDATA,DFN,1)
S VFIEN=$O(^BQI(90506.3,"B","Reproductive Factors",""))
S N=0,HEADR="",VALUE=""
F S N=$O(@NDATA@(N)) Q:'N D
. S CODE=$P(@NDATA@(N),U,1),VAL=$P(@NDATA@(N),U,3)
. I $E(CODE,1,2)'="RF" Q
. S IEN=""
. F S IEN=$O(^BQI(90506.3,VFIEN,10,"AC",CODE,IEN)) Q:IEN="" D
.. I $P(^BQI(90506.3,VFIEN,10,IEN,0),U,11)=1 Q
.. S HDR=$P(^BQI(90506.3,VFIEN,10,IEN,0),U,2)
.. NEW TYP,CIEN,TBL,GROOT,GBL
.. S TYP=$P($G(^BQI(90506.3,VFIEN,10,IEN,1)),U,1)
.. I TYP="C"!(TYP="T"),VAL'="" D
... I TYP="T" D
.... S TBL=$P($G(^BQI(90506.3,VFIEN,10,IEN,2)),U,3)
.... I VAL?1N.N S VAL=VAL_$C(28)_$$GET1^DIQ(TBL,VAL_",",".01","E") Q
.... S GROOT=$$ROOT^DILFD(TBL)
.... S GBL=GROOT_"""B"""_")"
.... S VAL=$O(@GBL@(VAL,""))
... I TYP="C" D
.... S CCIEN=$O(^BQI(90506.3,VFIEN,10,IEN,5,"B",VAL,"")) I CCIEN="" Q
.... S VAL=$P(^BQI(90506.3,VFIEN,10,IEN,5,CCIEN,0),U,2)
.. S HEADR=HEADR_HDR_U
.. S VALUE=VALUE_VAL_U
S HEADR=$$TKO^BQIUL1(HEADR,U)
S VALUE=$$TKO^BQIUL1(VALUE,U)
S @DATA@(II)=HEADR_$C(30)
S II=II+1,@DATA@(II)=VALUE_$C(30)
K @NDATA,NDATA
;
DONE ;
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
;
LOCK(DATA,DFN) ; EP - BQI LOCK REPROD FACTOR
N UID,X,BQII,MSG,VAL,RESULT,USER
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRFLK",UID))
K ^TMP("BQIRFLK",UID)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Create header record
S BQII=0,@DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
;
; Attempt lock and set RESULT accordingly
S RESULT=1
L +^AUPNREP(DFN):1 E S RESULT=0
;
; If lock is unsuccessful, get 'LAST LOCKED BY' from the panel.
I RESULT=0 D
. S USER=$G(^XTMP("BQIRFLK",DFN))
. S NAME=$$GET1^DIQ(200,USER,.01,"E")
. I NAME="" S NAME="an unknown user"
. S MSG="This record is currently being updated by "_NAME_"."
; If lock is successful, update 'LAST LOCKED BY' in ^XTMP.
I RESULT=1 D
. S ^XTMP("BQIRFLK",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Maintain locked by information for current locks of reproductive factors data"
. S ^XTMP("BQIRFLK",DFN)=DUZ
;
D SET
Q
;
UNLOCK(DATA,DFN) ; EP - BQI UNLOCK REPROD FACTOR
N UID,X,BQII,MSG,RESULT,USER
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRFLK",UID))
K ^TMP("BQIRFLK",UID)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Create header record
S BQII=0,@DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
;
; Get 'LAST LOCKED BY'.
S USER=$G(^XTMP("BQIRFLK",DFN))
;
; If 'LAST LOCKED BY' is this DUZ then delete the lock entry from ^XTMP.
I USER=DUZ K ^XTMP("BQIRFLK",DFN)
;
; Unlock and set RESULT
S RESULT=1
L -^AUPNREP(DFN)
D SET
Q
;
SET ; Report results
S BQII=BQII+1,@DATA@(BQII)=RESULT_"^"_$G(MSG)_$C(30)
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
BQIPTRPF ;VNGT/HS/ALA-Reproductive Factors Grid RPC ; 25 Jan 2010 1:26 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
EN(DATA,DFN) ; EP -- BQI REPRODUCTIVE FACTORS GRID
+1 ;
+2 ;Description - all the reproductive factors that a patient has in grid format
+3 ;
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ;
+7 NEW UID,II,VFIEN,HEADR,VALUE,N,CODE,VAL,IEN,HDR,SEX,AGE
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIPTRPF",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRPF D UNWIND^%ZTER"
+15 ;
+16 SET SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
SET AGE=$$AGE^BQIAGE(DFN)
+17 IF SEX'="F"
SET BMXSEC="RPC Failed: Patient is not Female"
QUIT
+18 ;
+19 DO REP^BQIPTRP1(.NDATA,DFN,1)
+20 SET VFIEN=$ORDER(^BQI(90506.3,"B","Reproductive Factors",""))
+21 SET N=0
SET HEADR=""
SET VALUE=""
+22 FOR
SET N=$ORDER(@NDATA@(N))
IF 'N
QUIT
Begin DoDot:1
+23 SET CODE=$PIECE(@NDATA@(N),U,1)
SET VAL=$PIECE(@NDATA@(N),U,3)
+24 IF $EXTRACT(CODE,1,2)'="RF"
QUIT
+25 SET IEN=""
+26 FOR
SET IEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",CODE,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+27 IF $PIECE(^BQI(90506.3,VFIEN,10,IEN,0),U,11)=1
QUIT
+28 SET HDR=$PIECE(^BQI(90506.3,VFIEN,10,IEN,0),U,2)
+29 NEW TYP,CIEN,TBL,GROOT,GBL
+30 SET TYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,IEN,1)),U,1)
+31 IF TYP="C"!(TYP="T")
IF VAL'=""
Begin DoDot:3
+32 IF TYP="T"
Begin DoDot:4
+33 SET TBL=$PIECE($GET(^BQI(90506.3,VFIEN,10,IEN,2)),U,3)
+34 IF VAL?1N.N
SET VAL=VAL_$CHAR(28)_$$GET1^DIQ(TBL,VAL_",",".01","E")
QUIT
+35 SET GROOT=$$ROOT^DILFD(TBL)
+36 SET GBL=GROOT_"""B"""_")"
+37 SET VAL=$ORDER(@GBL@(VAL,""))
End DoDot:4
+38 IF TYP="C"
Begin DoDot:4
+39 SET CCIEN=$ORDER(^BQI(90506.3,VFIEN,10,IEN,5,"B",VAL,""))
IF CCIEN=""
QUIT
+40 SET VAL=$PIECE(^BQI(90506.3,VFIEN,10,IEN,5,CCIEN,0),U,2)
End DoDot:4
End DoDot:3
+41 SET HEADR=HEADR_HDR_U
+42 SET VALUE=VALUE_VAL_U
End DoDot:2
End DoDot:1
+43 SET HEADR=$$TKO^BQIUL1(HEADR,U)
+44 SET VALUE=$$TKO^BQIUL1(VALUE,U)
+45 SET @DATA@(II)=HEADR_$CHAR(30)
+46 SET II=II+1
SET @DATA@(II)=VALUE_$CHAR(30)
+47 KILL @NDATA,NDATA
+48 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
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 ;
LOCK(DATA,DFN) ; EP - BQI LOCK REPROD FACTOR
+1 NEW UID,X,BQII,MSG,VAL,RESULT,USER
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIRFLK",UID))
+4 KILL ^TMP("BQIRFLK",UID)
+5 ;
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRPF D UNWIND^%ZTER"
+7 ;
+8 ; Create header record
+9 SET BQII=0
SET @DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+10 ;
+11 ; Attempt lock and set RESULT accordingly
+12 SET RESULT=1
+13 LOCK +^AUPNREP(DFN):1
IF '$TEST
SET RESULT=0
+14 ;
+15 ; If lock is unsuccessful, get 'LAST LOCKED BY' from the panel.
+16 IF RESULT=0
Begin DoDot:1
+17 SET USER=$GET(^XTMP("BQIRFLK",DFN))
+18 SET NAME=$$GET1^DIQ(200,USER,.01,"E")
+19 IF NAME=""
SET NAME="an unknown user"
+20 SET MSG="This record is currently being updated by "_NAME_"."
End DoDot:1
+21 ; If lock is successful, update 'LAST LOCKED BY' in ^XTMP.
+22 IF RESULT=1
Begin DoDot:1
+23 SET ^XTMP("BQIRFLK",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Maintain locked by information for current locks of reproductive factors data"
+24 SET ^XTMP("BQIRFLK",DFN)=DUZ
End DoDot:1
+25 ;
+26 DO SET
+27 QUIT
+28 ;
UNLOCK(DATA,DFN) ; EP - BQI UNLOCK REPROD FACTOR
+1 NEW UID,X,BQII,MSG,RESULT,USER
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIRFLK",UID))
+4 KILL ^TMP("BQIRFLK",UID)
+5 ;
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+7 ;
+8 ; Create header record
+9 SET BQII=0
SET @DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+10 ;
+11 ; Get 'LAST LOCKED BY'.
+12 SET USER=$GET(^XTMP("BQIRFLK",DFN))
+13 ;
+14 ; If 'LAST LOCKED BY' is this DUZ then delete the lock entry from ^XTMP.
+15 IF USER=DUZ
KILL ^XTMP("BQIRFLK",DFN)
+16 ;
+17 ; Unlock and set RESULT
+18 SET RESULT=1
+19 LOCK -^AUPNREP(DFN)
+20 DO SET
+21 QUIT
+22 ;
SET ; Report results
+1 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_"^"_$GET(MSG)_$CHAR(30)
+2 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+3 QUIT
