BDMDM8 ; IHS/CMI/LAB - PPD STUFF ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;IHS/TUCSON/LAB - patch 1 - 05/27/97 fixed cumulative TB STATUS calculation modified subroutine TBTXST and PPDCODE
;
;
START ;
PPD ;EP
S BDMX=BDMPD_"^LAST SKIN PPD" S BDMER=$$START1^APCLDF(BDMX,BDMY)
I '$D(BDM(1)) S ^TMP("BDM",$J,20)="No recorded PPD"
I $D(BDM(1)) S Y=$P(BDM(1),U) D DD^%DT S ^TMP("BDM",$J,20)=$S($P(^AUPNVSK(+$P(BDM(1),U,4),0),U,5)]"":$P(^(0),U,5)_"mm;",1:"")_$S($P(BDM(1),U,2)'="P":"NEGATIVE - "_Y,1:"POSITIVE - "_Y)
TBTXST ;TB Treatment Status, 21 get last TB related health factor
S %=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
I '% S ^TMP("BDM",$J,21)="TB Health Factor TAXONOMY MISSING!!" G PPDCODE ;IHS/TUCSON/LAB patch 1 - 05/27/97 - added this line
I % D
.S (X,Y)=0 F S X=$O(^AUPNHF("AA",BDMPD,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
.I Y S Y=$P(^AUTTHF(Y,0),U),^TMP("BDM",$J,21)=Y ;IHS/TUCSON/LAB - patch 1 - 05/27/97 modified this line
;I Y]"" S ^TMP("BDM",$J,21)=Y G TBCUML ;IHS/TUCSON/LAB - patch 1 - commented out this line and added line below
I $D(^TMP("BDM",$J,21)) G TBCUML
K BDM S BDMY="BDM(",BDMX=BDMPD_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S BDMER=$$START1^APCLDF(BDMX,BDMY)
S ^TMP("BDM",$J,21)=$S($D(BDM(1)):$P(BDM(1),U,3),1:"TB Health Factor Not recorded")
TBCUML I BDMCUML D
.I ^TMP("BDM",$J,21)["Not recorded" S BDMGOT1=1,BDMSUB=94 D CUML^BDMDM1 F BDMSUB=90:1:93 S BDMGOT1=0 D CUML^BDMDM1
.I ^TMP("BDM",$J,21)["TB - TX COMPLETE" S BDMGOT1=1,BDMSUB=90 D CUML^BDMDM1 F BDMSUB=91:1:94 S BDMGOT1=0 D CUML^BDMDM1
.I ^TMP("BDM",$J,21)["TB - TX INCOMPLETE" S BDMGOT1=1,BDMSUB=91 D CUML^BDMDM1 F BDMSUB=90,92,93,94 S BDMGOT1=0 D CUML^BDMDM1
.I ^TMP("BDM",$J,21)["TB - TX UNKNOWN" S BDMGOT1=1,BDMSUB=93 D CUML^BDMDM1 F BDMSUB=90,91,92,94 S BDMGOT1=0 D CUML^BDMDM1
.I ^TMP("BDM",$J,21)["TB - TX UNTREATED" S BDMGOT1=1,BDMSUB=92 D CUML^BDMDM1 F BDMSUB=90,91,93,94 S BDMGOT1=0 D CUML^BDMDM1
PPDCODE ;PPD STATUS CODE
S BDMJ=""
;IHS/TUCSON/LAB - patch 1 - added the 2 lines below
I $G(^TMP("BDM",$J,21))="TB - TX COMPLETE" S BDMJ=1 G PPDCUML
I $G(^TMP("BDM",$J,21))["TB - " S BDMJ=2 G PPDCUML
I ^TMP("BDM",$J,20)["POSITIVE" D G PPDCUML
.I $G(^TMP("BDM",$J,21))="TB - TX COMPLETE" S BDMJ=1
.S BDMJ=2
.Q
I ^TMP("BDM",$J,20)["NEGATIVE" S BDMJ=5 D G PPDCUML
.I ^TMP("BDM",$J,37)["not recorded" S BDMJ=5 Q
.S X=^TMP("BDM",$J,37),%DT="" D ^%DT S BDMI=Y,X=$P(^TMP("BDM",$J,20),"- ",2),%DT="" D ^%DT S BDMJ=$S(Y>BDMI:3,1:4)
.Q
S BDMJ=6
PPDCUML ;cumulative PPD
S ^TMP("BDM",$J,36)=$P($T(@BDMJ),";;",2)_" ("_BDMJ_")"
Q:'BDMCUML
S BDMI="70,71,72,73,74,75" F BDMX=1:1:6 S BDMSUB=$P(BDMI,",",BDMX),BDMGOT1=$S(BDMJ=BDMX:1,1:0) D CUML^BDMDM1
Q
;
TBCODE(DFN) ;
NEW BDMJ,BDMI
S BDMJ=""
;return computed TB Status Code
I ^TMP("BDM",$J,20)["POSITIVE" D Q BDMJ
.I $G(^TMP("BDM",$J,21))="TB - TX COMPLETE" S BDMJ=1
.S BDMJ=2
.Q
I ^TMP("BDM",$J,20)["NEGATIVE" S BDMJ=4 D Q BDMJ
.I ^TMP("BDM",$J,37)["not recorded" S BDMJ=4 Q
.S X=^TMP("BDM",$J,37),%DT="" D ^%DT S BDMI=Y,X=$P(^TMP("BDM",$J,20),"- ",2),%DT="" D ^%DT S X=$S(Y>BDMI:3,1:4)
.Q
S BDMJ=4
Q BDMJ
;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated or unknown treatment
3 ;;PPD -, up-to-date (placed after dm dx)
4 ;;PPD -, before DM dx
5 ;;PPD -, DM dx date unknown
6 ;;PPD Status unknown
BDMDM8 ; IHS/CMI/LAB - PPD STUFF ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;IHS/TUCSON/LAB - patch 1 - 05/27/97 fixed cumulative TB STATUS calculation modified subroutine TBTXST and PPDCODE
+3 ;
+4 ;
START ;
PPD ;EP
+1 SET BDMX=BDMPD_"^LAST SKIN PPD"
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+2 IF '$DATA(BDM(1))
SET ^TMP("BDM",$JOB,20)="No recorded PPD"
+3 IF $DATA(BDM(1))
SET Y=$PIECE(BDM(1),U)
DO DD^%DT
SET ^TMP("BDM",$JOB,20)=$SELECT($PIECE(^AUPNVSK(+$PIECE(BDM(1),U,4),0),U,5)]"":$PIECE(^(0),U,5)_"mm;",1:"")_$SELECT($PIECE(BDM(1),U,2)'="P":"NEGATIVE - "_Y,1:"POSITIVE - "_Y)
TBTXST ;TB Treatment Status, 21 get last TB related health factor
+1 SET %=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+2 ;IHS/TUCSON/LAB patch 1 - 05/27/97 - added this line
IF '%
SET ^TMP("BDM",$JOB,21)="TB Health Factor TAXONOMY MISSING!!"
GOTO PPDCODE
+3 IF %
Begin DoDot:1
+4 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",BDMPD,X))
IF X'=+X!(Y)
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET Y=X
+5 ;IHS/TUCSON/LAB - patch 1 - 05/27/97 modified this line
IF Y
SET Y=$PIECE(^AUTTHF(Y,0),U)
SET ^TMP("BDM",$JOB,21)=Y
End DoDot:1
+6 ;I Y]"" S ^TMP("BDM",$J,21)=Y G TBCUML ;IHS/TUCSON/LAB - patch 1 - commented out this line and added line below
+7 IF $DATA(^TMP("BDM",$JOB,21))
GOTO TBCUML
+8 KILL BDM
SET BDMY="BDM("
SET BDMX=BDMPD_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+9 SET ^TMP("BDM",$JOB,21)=$SELECT($DATA(BDM(1)):$PIECE(BDM(1),U,3),1:"TB Health Factor Not recorded")
TBCUML IF BDMCUML
Begin DoDot:1
+1 IF ^TMP("BDM",$JOB,21)["Not recorded"
SET BDMGOT1=1
SET BDMSUB=94
DO CUML^BDMDM1
FOR BDMSUB=90:1:93
SET BDMGOT1=0
DO CUML^BDMDM1
+2 IF ^TMP("BDM",$JOB,21)["TB - TX COMPLETE"
SET BDMGOT1=1
SET BDMSUB=90
DO CUML^BDMDM1
FOR BDMSUB=91:1:94
SET BDMGOT1=0
DO CUML^BDMDM1
+3 IF ^TMP("BDM",$JOB,21)["TB - TX INCOMPLETE"
SET BDMGOT1=1
SET BDMSUB=91
DO CUML^BDMDM1
FOR BDMSUB=90,92,93,94
SET BDMGOT1=0
DO CUML^BDMDM1
+4 IF ^TMP("BDM",$JOB,21)["TB - TX UNKNOWN"
SET BDMGOT1=1
SET BDMSUB=93
DO CUML^BDMDM1
FOR BDMSUB=90,91,92,94
SET BDMGOT1=0
DO CUML^BDMDM1
+5 IF ^TMP("BDM",$JOB,21)["TB - TX UNTREATED"
SET BDMGOT1=1
SET BDMSUB=92
DO CUML^BDMDM1
FOR BDMSUB=90,91,93,94
SET BDMGOT1=0
DO CUML^BDMDM1
End DoDot:1
PPDCODE ;PPD STATUS CODE
+1 SET BDMJ=""
+2 ;IHS/TUCSON/LAB - patch 1 - added the 2 lines below
+3 IF $GET(^TMP("BDM",$JOB,21))="TB - TX COMPLETE"
SET BDMJ=1
GOTO PPDCUML
+4 IF $GET(^TMP("BDM",$JOB,21))["TB - "
SET BDMJ=2
GOTO PPDCUML
+5 IF ^TMP("BDM",$JOB,20)["POSITIVE"
Begin DoDot:1
+6 IF $GET(^TMP("BDM",$JOB,21))="TB - TX COMPLETE"
SET BDMJ=1
+7 SET BDMJ=2
+8 QUIT
End DoDot:1
GOTO PPDCUML
+9 IF ^TMP("BDM",$JOB,20)["NEGATIVE"
SET BDMJ=5
Begin DoDot:1
+10 IF ^TMP("BDM",$JOB,37)["not recorded"
SET BDMJ=5
QUIT
+11 SET X=^TMP("BDM",$JOB,37)
SET %DT=""
DO ^%DT
SET BDMI=Y
SET X=$PIECE(^TMP("BDM",$JOB,20),"- ",2)
SET %DT=""
DO ^%DT
SET BDMJ=$SELECT(Y>BDMI:3,1:4)
+12 QUIT
End DoDot:1
GOTO PPDCUML
+13 SET BDMJ=6
PPDCUML ;cumulative PPD
+1 SET ^TMP("BDM",$JOB,36)=$PIECE($TEXT(@BDMJ),";;",2)_" ("_BDMJ_")"
+2 IF 'BDMCUML
QUIT
+3 SET BDMI="70,71,72,73,74,75"
FOR BDMX=1:1:6
SET BDMSUB=$PIECE(BDMI,",",BDMX)
SET BDMGOT1=$SELECT(BDMJ=BDMX:1,1:0)
DO CUML^BDMDM1
+4 QUIT
+5 ;
TBCODE(DFN) ;
+1 NEW BDMJ,BDMI
+2 SET BDMJ=""
+3 ;return computed TB Status Code
+4 IF ^TMP("BDM",$JOB,20)["POSITIVE"
Begin DoDot:1
+5 IF $GET(^TMP("BDM",$JOB,21))="TB - TX COMPLETE"
SET BDMJ=1
+6 SET BDMJ=2
+7 QUIT
End DoDot:1
QUIT BDMJ
+8 IF ^TMP("BDM",$JOB,20)["NEGATIVE"
SET BDMJ=4
Begin DoDot:1
+9 IF ^TMP("BDM",$JOB,37)["not recorded"
SET BDMJ=4
QUIT
+10 SET X=^TMP("BDM",$JOB,37)
SET %DT=""
DO ^%DT
SET BDMI=Y
SET X=$PIECE(^TMP("BDM",$JOB,20),"- ",2)
SET %DT=""
DO ^%DT
SET X=$SELECT(Y>BDMI:3,1:4)
+11 QUIT
End DoDot:1
QUIT BDMJ
+12 SET BDMJ=4
+13 QUIT BDMJ
+14 ;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated or unknown treatment
3 ;;PPD -, up-to-date (placed after dm dx)
4 ;;PPD -, before DM dx
5 ;;PPD -, DM dx date unknown
6 ;;PPD Status unknown
