BQIRGPG ;GDIT/HS/ALA-Pregnancy Care Mgmt ; 17 Jul 2013 7:49 AM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
CURR(DFN) ;EP - Currently marked as pregnant
NEW RESULT
S RESULT="NO"
I $$GET1^DIQ(9000017,DFN_",",1101,"E")'="" S RESULT=$$GET1^DIQ(9000017,DFN_",",1101,"E")
Q RESULT
;
EDD(DFN) ;EP - Definitive Date of Delivery
NEW RES,ARRAY,PI,PDATA,EDD
S RES="",PDATA=$G(^AUPNREP(DFN,13))
S PI=11
I $P(PDATA,U,PI)'="" S EDD=$P(PDATA,U,PI)
I $G(EDD)'="" S RES=$$FMTE^BQIUL1(EDD)
Q RES
;
EEDD(DFN) ; EP - Estimated Date of Delivery
NEW RES,ARRAY,PI,PDATA,EDD
S RES="",PDATA=$G(^AUPNREP(DFN,13))
F PI=2,5,8,14 D
. I $P(PDATA,U,PI)'="" S ARRAY($P(PDATA,U,PI))=PI
S EDD=$O(ARRAY(""),-1) I EDD'="" S RES=$$FMTE^BQIUL1(EDD)
Q RES
;
HGH(DFN) ;EP - High Risk Prenatal Problems
NEW BQJN,OK
S OK="NO",BQJN=""
F S BQJN=$O(^BJPNPL("D",DFN,BQJN)) Q:BQJN="" D
. I $P(^BJPNPL(BQJN,0),U,6)="H" S OK="YES"
Q OK
;
EGA(DFN) ;EP - Estimated gestational age
NEW VALL,RES,DATE
S RES=""
S VALL=$$MEAS^BQITUTL(DFN,"EGA")
I VALL=0 Q RES
S RES=$P(VALL,U,3)_" ("_$$FMTE^BQIUL1($P(VALL,U,2))_")"
Q RES
;
GRAV(DFN) ;EP - Gravida Total # of pregnancies
NEW RES
S RES=+$$GET1^DIQ(9000017,DFN_",",1103,"E")
Q RES
;
LAB ;EP - Pull out prenatal lab tests
NEW LRES,RES
S LRES=$$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,.TREF)
I $P(LRES,U,1)=0 S RESULT=0 Q
S RES=$P(LRES,U,7) I RES="" S RES=$P(LRES,U,6)
S RESULT=1_U_$P(LRES,U,2)_U_RES
Q
;
LBT ;EP - Set up lab tests
NEW TAX,TREF
S TAX="BQI PRENATAL TAX"
S TREF=$NA(^TMP("BQIPRENTL",$J)) K @TREF
D BLD^BQITUTL(TAX,.TREF,"L")
; Clean up labs
NEW DA,IENS,CIEN
S CIEN=$O(^BQI(90506.5,"B","Prenatal","")) I CIEN="" Q
S DA=0,DA(1)=CIEN
F S DA=$O(^BQI(90506.5,CIEN,10,DA)) Q:'DA D
. S IENS=$$IENS^DILF(.DA)
. S BQIUPD(90506.51,IENS,.09)=1
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
;
; Set up lab tests
NEW BN,CT,CD,DA,IENS,DIC,DESC,PNL,DLAYGO,DIC,X,Y,NM,NAME
S BN=0
F S BN=$O(@TREF@(BN)) Q:'BN D
. S NM=$P(^LAB(60,BN,.1),U,1),NAME=$P(^LAB(60,BN,0),"^",1)
. S PNL=0 I $O(^LAB(60,BN,2,0))'="" S PNL=1
. S IEN=$O(^BQI(90506.5,CIEN,10,"C",NM,""))
. I IEN'="" D
.. S DA(1)=CIEN,DA=IEN,IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90506.51,IENS,.09)="@"
.. D FILE^DIE("","BQIUPD","ERROR")
.. I PNL S DESC(1)="Most recent "_NAME_" panel from V Lab is displayed."
.. I 'PNL S DESC(1)="Most recent "_NAME_" lab test from V Lab is displayed."
.. D WP^DIE(90506.51,IENS,4,"","DESC")
. I IEN="" D
.. S CT=$P($G(^BQI(90506.5,CIEN,10,0)),U,3),CT=CT+1
.. S CD="PG_"_$E("0000",$L(CT),2)_CT
.. S DA(1)=CIEN,X=CD,DIC="^BQI(90506.5,"_DA(1)_",10,",DIC(0)="L",DLAYGO=90506.51
.. K DO,DD D FILE^DICN S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90506.51,IENS,.02)=3,BQIUPD(90506.51,IENS,.03)=NM
.. S BQIUPD(90506.51,IENS,.04)=BN,BQIUPD(90506.51,IENS,.05)="B"
.. S BQIUPD(90506.51,IENS,.06)="D",BQIUPD(90506.51,IENS,.08)="A"
.. S BQIUPD(90506.51,IENS,1)="D LAB^BQIRGPG"
.. D FILE^DIE("","BQIUPD","ERROR")
.. I PNL S DESC(1)="Most recent "_NAME_" panel from V Lab is displayed."
.. I 'PNL S DESC(1)="Most recent "_NAME_" lab test from V Lab is displayed."
.. D WP^DIE(90506.51,IENS,4,"","DESC")
K @TREF
Q
;
GLS(DATA,FAKE) ;EP - BQI GET PRENATAL GLOSSARY
NEW UID,II,TRIEN,CAT,TIT,SORT,RMK,REMARK,CT,NXT,GLIEN,IEN
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRGPGLS",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGPG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T32767REPORT_TEXT"_$C(30)
S GLIEN=$O(^BQI(90508.2,"B","Prenatal","")) I GLIEN="" S BMXSEC="Problem with Prenatal glossary in file 90508.2" G DONE
S IEN=0 F S IEN=$O(^BQI(90508.2,GLIEN,1,IEN)) Q:'IEN D
. S II=II+1,@DATA@(II)=$G(^BQI(90508.2,GLIEN,1,IEN,0))
;S GLIEN=$O(^BQI(90506.5,"B","Prenatal","")) I GLIEN="" S BMXSEC="Problem with Prenatal source list" G DONE
;S IEN=0 F S IEN=$O(^BQI(90506.5,GLIEN,10,IEN)) Q:'IEN D
;. S IIEN=$P(^BQI(90506.5,GLIEN,10,IEN,0),U,4)
;. S II=II+1,@DATA@(II)=" "_$P(^BQI(90506.5,GLIEN,10,IEN,0),U,3)_" ("_$P($G(^LAB(60,IIEN,0)),U,1)_")"
I II>0 S @DATA@(II)=@DATA@(II)_$C(30)
;
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
BQIRGPG ;GDIT/HS/ALA-Pregnancy Care Mgmt ; 17 Jul 2013 7:49 AM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
CURR(DFN) ;EP - Currently marked as pregnant
+1 NEW RESULT
+2 SET RESULT="NO"
+3 IF $$GET1^DIQ(9000017,DFN_",",1101,"E")'=""
SET RESULT=$$GET1^DIQ(9000017,DFN_",",1101,"E")
+4 QUIT RESULT
+5 ;
EDD(DFN) ;EP - Definitive Date of Delivery
+1 NEW RES,ARRAY,PI,PDATA,EDD
+2 SET RES=""
SET PDATA=$GET(^AUPNREP(DFN,13))
+3 SET PI=11
+4 IF $PIECE(PDATA,U,PI)'=""
SET EDD=$PIECE(PDATA,U,PI)
+5 IF $GET(EDD)'=""
SET RES=$$FMTE^BQIUL1(EDD)
+6 QUIT RES
+7 ;
EEDD(DFN) ; EP - Estimated Date of Delivery
+1 NEW RES,ARRAY,PI,PDATA,EDD
+2 SET RES=""
SET PDATA=$GET(^AUPNREP(DFN,13))
+3 FOR PI=2,5,8,14
Begin DoDot:1
+4 IF $PIECE(PDATA,U,PI)'=""
SET ARRAY($PIECE(PDATA,U,PI))=PI
End DoDot:1
+5 SET EDD=$ORDER(ARRAY(""),-1)
IF EDD'=""
SET RES=$$FMTE^BQIUL1(EDD)
+6 QUIT RES
+7 ;
HGH(DFN) ;EP - High Risk Prenatal Problems
+1 NEW BQJN,OK
+2 SET OK="NO"
SET BQJN=""
+3 FOR
SET BQJN=$ORDER(^BJPNPL("D",DFN,BQJN))
IF BQJN=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^BJPNPL(BQJN,0),U,6)="H"
SET OK="YES"
End DoDot:1
+5 QUIT OK
+6 ;
EGA(DFN) ;EP - Estimated gestational age
+1 NEW VALL,RES,DATE
+2 SET RES=""
+3 SET VALL=$$MEAS^BQITUTL(DFN,"EGA")
+4 IF VALL=0
QUIT RES
+5 SET RES=$PIECE(VALL,U,3)_" ("_$$FMTE^BQIUL1($PIECE(VALL,U,2))_")"
+6 QUIT RES
+7 ;
GRAV(DFN) ;EP - Gravida Total # of pregnancies
+1 NEW RES
+2 SET RES=+$$GET1^DIQ(9000017,DFN_",",1103,"E")
+3 QUIT RES
+4 ;
LAB ;EP - Pull out prenatal lab tests
+1 NEW LRES,RES
+2 SET LRES=$$ITM^BQICMUTL("",BQDFN,FREF,RREF,ITM,TAX,.TREF)
+3 IF $PIECE(LRES,U,1)=0
SET RESULT=0
QUIT
+4 SET RES=$PIECE(LRES,U,7)
IF RES=""
SET RES=$PIECE(LRES,U,6)
+5 SET RESULT=1_U_$PIECE(LRES,U,2)_U_RES
+6 QUIT
+7 ;
LBT ;EP - Set up lab tests
+1 NEW TAX,TREF
+2 SET TAX="BQI PRENATAL TAX"
+3 SET TREF=$NAME(^TMP("BQIPRENTL",$JOB))
KILL @TREF
+4 DO BLD^BQITUTL(TAX,.TREF,"L")
+5 ; Clean up labs
+6 NEW DA,IENS,CIEN
+7 SET CIEN=$ORDER(^BQI(90506.5,"B","Prenatal",""))
IF CIEN=""
QUIT
+8 SET DA=0
SET DA(1)=CIEN
+9 FOR
SET DA=$ORDER(^BQI(90506.5,CIEN,10,DA))
IF 'DA
QUIT
Begin DoDot:1
+10 SET IENS=$$IENS^DILF(.DA)
+11 SET BQIUPD(90506.51,IENS,.09)=1
End DoDot:1
+12 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+13 ;
+14 ; Set up lab tests
+15 NEW BN,CT,CD,DA,IENS,DIC,DESC,PNL,DLAYGO,DIC,X,Y,NM,NAME
+16 SET BN=0
+17 FOR
SET BN=$ORDER(@TREF@(BN))
IF 'BN
QUIT
Begin DoDot:1
+18 SET NM=$PIECE(^LAB(60,BN,.1),U,1)
SET NAME=$PIECE(^LAB(60,BN,0),"^",1)
+19 SET PNL=0
IF $ORDER(^LAB(60,BN,2,0))'=""
SET PNL=1
+20 SET IEN=$ORDER(^BQI(90506.5,CIEN,10,"C",NM,""))
+21 IF IEN'=""
Begin DoDot:2
+22 SET DA(1)=CIEN
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+23 SET BQIUPD(90506.51,IENS,.09)="@"
+24 DO FILE^DIE("","BQIUPD","ERROR")
+25 IF PNL
SET DESC(1)="Most recent "_NAME_" panel from V Lab is displayed."
+26 IF 'PNL
SET DESC(1)="Most recent "_NAME_" lab test from V Lab is displayed."
+27 DO WP^DIE(90506.51,IENS,4,"","DESC")
End DoDot:2
+28 IF IEN=""
Begin DoDot:2
+29 SET CT=$PIECE($GET(^BQI(90506.5,CIEN,10,0)),U,3)
SET CT=CT+1
+30 SET CD="PG_"_$EXTRACT("0000",$LENGTH(CT),2)_CT
+31 SET DA(1)=CIEN
SET X=CD
SET DIC="^BQI(90506.5,"_DA(1)_",10,"
SET DIC(0)="L"
SET DLAYGO=90506.51
+32 KILL DO,DD
DO FILE^DICN
SET DA=+Y
+33 SET IENS=$$IENS^DILF(.DA)
+34 SET BQIUPD(90506.51,IENS,.02)=3
SET BQIUPD(90506.51,IENS,.03)=NM
+35 SET BQIUPD(90506.51,IENS,.04)=BN
SET BQIUPD(90506.51,IENS,.05)="B"
+36 SET BQIUPD(90506.51,IENS,.06)="D"
SET BQIUPD(90506.51,IENS,.08)="A"
+37 SET BQIUPD(90506.51,IENS,1)="D LAB^BQIRGPG"
+38 DO FILE^DIE("","BQIUPD","ERROR")
+39 IF PNL
SET DESC(1)="Most recent "_NAME_" panel from V Lab is displayed."
+40 IF 'PNL
SET DESC(1)="Most recent "_NAME_" lab test from V Lab is displayed."
+41 DO WP^DIE(90506.51,IENS,4,"","DESC")
End DoDot:2
End DoDot:1
+42 KILL @TREF
+43 QUIT
+44 ;
GLS(DATA,FAKE) ;EP - BQI GET PRENATAL GLOSSARY
+1 NEW UID,II,TRIEN,CAT,TIT,SORT,RMK,REMARK,CT,NXT,GLIEN,IEN
+2 ;
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRGPGLS",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRGPG D UNWIND^%ZTER"
+9 ;
+10 SET @DATA@(II)="T32767REPORT_TEXT"_$CHAR(30)
+11 SET GLIEN=$ORDER(^BQI(90508.2,"B","Prenatal",""))
IF GLIEN=""
SET BMXSEC="Problem with Prenatal glossary in file 90508.2"
GOTO DONE
+12 SET IEN=0
FOR
SET IEN=$ORDER(^BQI(90508.2,GLIEN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+13 SET II=II+1
SET @DATA@(II)=$GET(^BQI(90508.2,GLIEN,1,IEN,0))
End DoDot:1
+14 ;S GLIEN=$O(^BQI(90506.5,"B","Prenatal","")) I GLIEN="" S BMXSEC="Problem with Prenatal source list" G DONE
+15 ;S IEN=0 F S IEN=$O(^BQI(90506.5,GLIEN,10,IEN)) Q:'IEN D
+16 ;. S IIEN=$P(^BQI(90506.5,GLIEN,10,IEN,0),U,4)
+17 ;. S II=II+1,@DATA@(II)=" "_$P(^BQI(90506.5,GLIEN,10,IEN,0),U,3)_" ("_$P($G(^LAB(60,IIEN,0)),U,1)_")"
+18 IF II>0
SET @DATA@(II)=@DATA@(II)_$CHAR(30)
+19 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
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
