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

BQIPTRPF.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. EN(DATA,DFN) ; EP -- BQI REPRODUCTIVE FACTORS GRID
  1.  ;
  1.  ;Description - all the reproductive factors that a patient has in grid format
  1.  ;
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  ;
  1.  NEW UID,II,VFIEN,HEADR,VALUE,N,CODE,VAL,IEN,HDR,SEX,AGE
  1.  ;
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTRPF",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S SEX=$$GET1^DIQ(2,DFN_",",.02,"I"),AGE=$$AGE^BQIAGE(DFN)
  1.  I SEX'="F" S BMXSEC="RPC Failed: Patient is not Female" Q
  1.  ;
  1.  D REP^BQIPTRP1(.NDATA,DFN,1)
  1.  S VFIEN=$O(^BQI(90506.3,"B","Reproductive Factors",""))
  1.  S N=0,HEADR="",VALUE=""
  1.  F  S N=$O(@NDATA@(N)) Q:'N  D
  1.  . S CODE=$P(@NDATA@(N),U,1),VAL=$P(@NDATA@(N),U,3)
  1.  . I $E(CODE,1,2)'="RF" Q
  1.  . S IEN=""
  1.  . F  S IEN=$O(^BQI(90506.3,VFIEN,10,"AC",CODE,IEN)) Q:IEN=""  D
  1.  .. I $P(^BQI(90506.3,VFIEN,10,IEN,0),U,11)=1 Q
  1.  .. S HDR=$P(^BQI(90506.3,VFIEN,10,IEN,0),U,2)
  1.  .. NEW TYP,CIEN,TBL,GROOT,GBL
  1.  .. S TYP=$P($G(^BQI(90506.3,VFIEN,10,IEN,1)),U,1)
  1.  .. I TYP="C"!(TYP="T"),VAL'="" D
  1.  ... I TYP="T" D
  1.  .... S TBL=$P($G(^BQI(90506.3,VFIEN,10,IEN,2)),U,3)
  1.  .... I VAL?1N.N S VAL=VAL_$C(28)_$$GET1^DIQ(TBL,VAL_",",".01","E") Q
  1.  .... S GROOT=$$ROOT^DILFD(TBL)
  1.  .... S GBL=GROOT_"""B"""_")"
  1.  .... S VAL=$O(@GBL@(VAL,""))
  1.  ... I TYP="C" D
  1.  .... S CCIEN=$O(^BQI(90506.3,VFIEN,10,IEN,5,"B",VAL,"")) I CCIEN="" Q
  1.  .... S VAL=$P(^BQI(90506.3,VFIEN,10,IEN,5,CCIEN,0),U,2)
  1.  .. S HEADR=HEADR_HDR_U
  1.  .. S VALUE=VALUE_VAL_U
  1.  S HEADR=$$TKO^BQIUL1(HEADR,U)
  1.  S VALUE=$$TKO^BQIUL1(VALUE,U)
  1.  S @DATA@(II)=HEADR_$C(30)
  1.  S II=II+1,@DATA@(II)=VALUE_$C(30)
  1.  K @NDATA,NDATA
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  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. LOCK(DATA,DFN) ; EP - BQI LOCK REPROD FACTOR
  1.  N UID,X,BQII,MSG,VAL,RESULT,USER
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIRFLK",UID))
  1.  K ^TMP("BQIRFLK",UID)
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRPF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ; Create header record
  1.  S BQII=0,@DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
  1.  ;
  1.  ; Attempt lock and set RESULT accordingly
  1.  S RESULT=1
  1.  L +^AUPNREP(DFN):1 E  S RESULT=0
  1.  ;
  1.  ; If lock is unsuccessful, get 'LAST LOCKED BY' from the panel.
  1.  I RESULT=0 D
  1.  . S USER=$G(^XTMP("BQIRFLK",DFN))
  1.  . S NAME=$$GET1^DIQ(200,USER,.01,"E")
  1.  . I NAME="" S NAME="an unknown user"
  1.  . S MSG="This record is currently being updated by "_NAME_"."
  1.  ; If lock is successful, update 'LAST LOCKED BY' in ^XTMP.
  1.  I RESULT=1 D
  1.  . S ^XTMP("BQIRFLK",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Maintain locked by information for current locks of reproductive factors data"
  1.  . S ^XTMP("BQIRFLK",DFN)=DUZ
  1.  ;
  1.  D SET
  1.  Q
  1.  ;
  1. UNLOCK(DATA,DFN) ; EP - BQI UNLOCK REPROD FACTOR
  1.  N UID,X,BQII,MSG,RESULT,USER
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIRFLK",UID))
  1.  K ^TMP("BQIRFLK",UID)
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  ; Create header record
  1.  S BQII=0,@DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
  1.  ;
  1.  ; Get 'LAST LOCKED BY'.
  1.  S USER=$G(^XTMP("BQIRFLK",DFN))
  1.  ;
  1.  ; If 'LAST LOCKED BY' is this DUZ then delete the lock entry from ^XTMP.
  1.  I USER=DUZ K ^XTMP("BQIRFLK",DFN)
  1.  ;
  1.  ; Unlock and set RESULT
  1.  S RESULT=1
  1.  L -^AUPNREP(DFN)
  1.  D SET
  1.  Q
  1.  ;
  1. SET ; Report results
  1.  S BQII=BQII+1,@DATA@(BQII)=RESULT_"^"_$G(MSG)_$C(30)
  1.  S BQII=BQII+1,@DATA@(BQII)=$C(31)
  1.  Q