- APCLDM8 ; IHS/CMI/LAB - PPD STUFF ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;IHS/TUCSON/LAB - patch 1 - 05/27/97 fixed cumulative TB STATUS calculation modified subroutine TBTXST and PPDCODE
- ;
- ;
- START ;
- PPD ;EP
- S APCLX=APCLPD_"^LAST SKIN PPD" S APCLER=$$START1^APCLDF(APCLX,APCLY)
- I '$D(APCL(1)) S ^TMP("APCL",$J,20)="No recorded PPD"
- I $D(APCL(1)) S Y=$P(APCL(1),U) D DD^%DT S ^TMP("APCL",$J,20)=$S($P(^AUPNVSK(+$P(APCL(1),U,4),0),U,5)]"":$P(^(0),U,5)_"mm;",1:"")_$S($P(APCL(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("APCL",$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",APCLPD,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
- .I Y S Y=$P(^AUTTHF(Y,0),U),^TMP("APCL",$J,21)=Y ;IHS/TUCSON/LAB - patch 1 - 05/27/97 modified this line
- ;I Y]"" S ^TMP("APCL",$J,21)=Y G TBCUML ;IHS/TUCSON/LAB - patch 1 - commented out this line and added line below
- I $D(^TMP("APCL",$J,21)) G TBCUML
- K APCL S APCLY="APCL(",APCLX=APCLPD_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S APCLER=$$START1^APCLDF(APCLX,APCLY)
- S ^TMP("APCL",$J,21)=$S($D(APCL(1)):$P(APCL(1),U,3),1:"TB Health Factor Not recorded")
- TBCUML I APCLCUML D
- .I ^TMP("APCL",$J,21)["Not recorded" S APCLGOT1=1,APCLSUB=94 D CUML^APCLDM1 F APCLSUB=90:1:93 S APCLGOT1=0 D CUML^APCLDM1
- .I ^TMP("APCL",$J,21)["TB - TX COMPLETE" S APCLGOT1=1,APCLSUB=90 D CUML^APCLDM1 F APCLSUB=91:1:94 S APCLGOT1=0 D CUML^APCLDM1
- .I ^TMP("APCL",$J,21)["TB - TX INCOMPLETE" S APCLGOT1=1,APCLSUB=91 D CUML^APCLDM1 F APCLSUB=90,92,93,94 S APCLGOT1=0 D CUML^APCLDM1
- .I ^TMP("APCL",$J,21)["TB - TX UNKNOWN" S APCLGOT1=1,APCLSUB=93 D CUML^APCLDM1 F APCLSUB=90,91,92,94 S APCLGOT1=0 D CUML^APCLDM1
- .I ^TMP("APCL",$J,21)["TB - TX UNTREATED" S APCLGOT1=1,APCLSUB=92 D CUML^APCLDM1 F APCLSUB=90,91,93,94 S APCLGOT1=0 D CUML^APCLDM1
- PPDCODE ;PPD STATUS CODE
- S APCLJ=""
- ;IHS/TUCSON/LAB - patch 1 - added the 2 lines below
- I $G(^TMP("APCL",$J,21))="TB - TX COMPLETE" S APCLJ=1 G PPDCUML
- I $G(^TMP("APCL",$J,21))["TB - " S APCLJ=2 G PPDCUML
- I ^TMP("APCL",$J,20)["POSITIVE" D G PPDCUML
- .I $G(^TMP("APCL",$J,21))="TB - TX COMPLETE" S APCLJ=1
- .S APCLJ=2
- .Q
- I ^TMP("APCL",$J,20)["NEGATIVE" S APCLJ=5 D G PPDCUML
- .I ^TMP("APCL",$J,37)["not recorded" S APCLJ=5 Q
- .S X=^TMP("APCL",$J,37),%DT="" D ^%DT S APCLI=Y,X=$P(^TMP("APCL",$J,20),"- ",2),%DT="" D ^%DT S APCLJ=$S(Y>APCLI:3,1:4)
- .Q
- S APCLJ=6
- PPDCUML ;cumulative PPD
- S ^TMP("APCL",$J,36)=$P($T(@APCLJ),";;",2)_" ("_APCLJ_")"
- Q:'APCLCUML
- S APCLI="70,71,72,73,74,75" F APCLX=1:1:6 S APCLSUB=$P(APCLI,",",APCLX),APCLGOT1=$S(APCLJ=APCLX:1,1:0) D CUML^APCLDM1
- Q
- ;
- TBCODE(DFN) ;
- NEW APCLJ,APCLI
- S APCLJ=""
- ;return computed TB Status Code
- I ^TMP("APCL",$J,20)["POSITIVE" D Q APCLJ
- .I $G(^TMP("APCL",$J,21))="TB - TX COMPLETE" S APCLJ=1
- .S APCLJ=2
- .Q
- I ^TMP("APCL",$J,20)["NEGATIVE" S APCLJ=4 D Q APCLJ
- .I ^TMP("APCL",$J,37)["not recorded" S APCLJ=4 Q
- .S X=^TMP("APCL",$J,37),%DT="" D ^%DT S APCLI=Y,X=$P(^TMP("APCL",$J,20),"- ",2),%DT="" D ^%DT S X=$S(Y>APCLI:3,1:4)
- .Q
- S APCLJ=4
- Q APCLJ
- ;;
- 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
- APCLDM8 ; IHS/CMI/LAB - PPD STUFF ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +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 APCLX=APCLPD_"^LAST SKIN PPD"
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- +2 IF '$DATA(APCL(1))
- SET ^TMP("APCL",$JOB,20)="No recorded PPD"
- +3 IF $DATA(APCL(1))
- SET Y=$PIECE(APCL(1),U)
- DO DD^%DT
- SET ^TMP("APCL",$JOB,20)=$SELECT($PIECE(^AUPNVSK(+$PIECE(APCL(1),U,4),0),U,5)]"":$PIECE(^(0),U,5)_"mm;",1:"")_$SELECT($PIECE(APCL(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("APCL",$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",APCLPD,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("APCL",$JOB,21)=Y
- End DoDot:1
- +6 ;I Y]"" S ^TMP("APCL",$J,21)=Y G TBCUML ;IHS/TUCSON/LAB - patch 1 - commented out this line and added line below
- +7 IF $DATA(^TMP("APCL",$JOB,21))
- GOTO TBCUML
- +8 KILL APCL
- SET APCLY="APCL("
- SET APCLX=APCLPD_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- +9 SET ^TMP("APCL",$JOB,21)=$SELECT($DATA(APCL(1)):$PIECE(APCL(1),U,3),1:"TB Health Factor Not recorded")
- TBCUML IF APCLCUML
- Begin DoDot:1
- +1 IF ^TMP("APCL",$JOB,21)["Not recorded"
- SET APCLGOT1=1
- SET APCLSUB=94
- DO CUML^APCLDM1
- FOR APCLSUB=90:1:93
- SET APCLGOT1=0
- DO CUML^APCLDM1
- +2 IF ^TMP("APCL",$JOB,21)["TB - TX COMPLETE"
- SET APCLGOT1=1
- SET APCLSUB=90
- DO CUML^APCLDM1
- FOR APCLSUB=91:1:94
- SET APCLGOT1=0
- DO CUML^APCLDM1
- +3 IF ^TMP("APCL",$JOB,21)["TB - TX INCOMPLETE"
- SET APCLGOT1=1
- SET APCLSUB=91
- DO CUML^APCLDM1
- FOR APCLSUB=90,92,93,94
- SET APCLGOT1=0
- DO CUML^APCLDM1
- +4 IF ^TMP("APCL",$JOB,21)["TB - TX UNKNOWN"
- SET APCLGOT1=1
- SET APCLSUB=93
- DO CUML^APCLDM1
- FOR APCLSUB=90,91,92,94
- SET APCLGOT1=0
- DO CUML^APCLDM1
- +5 IF ^TMP("APCL",$JOB,21)["TB - TX UNTREATED"
- SET APCLGOT1=1
- SET APCLSUB=92
- DO CUML^APCLDM1
- FOR APCLSUB=90,91,93,94
- SET APCLGOT1=0
- DO CUML^APCLDM1
- End DoDot:1
- PPDCODE ;PPD STATUS CODE
- +1 SET APCLJ=""
- +2 ;IHS/TUCSON/LAB - patch 1 - added the 2 lines below
- +3 IF $GET(^TMP("APCL",$JOB,21))="TB - TX COMPLETE"
- SET APCLJ=1
- GOTO PPDCUML
- +4 IF $GET(^TMP("APCL",$JOB,21))["TB - "
- SET APCLJ=2
- GOTO PPDCUML
- +5 IF ^TMP("APCL",$JOB,20)["POSITIVE"
- Begin DoDot:1
- +6 IF $GET(^TMP("APCL",$JOB,21))="TB - TX COMPLETE"
- SET APCLJ=1
- +7 SET APCLJ=2
- +8 QUIT
- End DoDot:1
- GOTO PPDCUML
- +9 IF ^TMP("APCL",$JOB,20)["NEGATIVE"
- SET APCLJ=5
- Begin DoDot:1
- +10 IF ^TMP("APCL",$JOB,37)["not recorded"
- SET APCLJ=5
- QUIT
- +11 SET X=^TMP("APCL",$JOB,37)
- SET %DT=""
- DO ^%DT
- SET APCLI=Y
- SET X=$PIECE(^TMP("APCL",$JOB,20),"- ",2)
- SET %DT=""
- DO ^%DT
- SET APCLJ=$SELECT(Y>APCLI:3,1:4)
- +12 QUIT
- End DoDot:1
- GOTO PPDCUML
- +13 SET APCLJ=6
- PPDCUML ;cumulative PPD
- +1 SET ^TMP("APCL",$JOB,36)=$PIECE($TEXT(@APCLJ),";;",2)_" ("_APCLJ_")"
- +2 IF 'APCLCUML
- QUIT
- +3 SET APCLI="70,71,72,73,74,75"
- FOR APCLX=1:1:6
- SET APCLSUB=$PIECE(APCLI,",",APCLX)
- SET APCLGOT1=$SELECT(APCLJ=APCLX:1,1:0)
- DO CUML^APCLDM1
- +4 QUIT
- +5 ;
- TBCODE(DFN) ;
- +1 NEW APCLJ,APCLI
- +2 SET APCLJ=""
- +3 ;return computed TB Status Code
- +4 IF ^TMP("APCL",$JOB,20)["POSITIVE"
- Begin DoDot:1
- +5 IF $GET(^TMP("APCL",$JOB,21))="TB - TX COMPLETE"
- SET APCLJ=1
- +6 SET APCLJ=2
- +7 QUIT
- End DoDot:1
- QUIT APCLJ
- +8 IF ^TMP("APCL",$JOB,20)["NEGATIVE"
- SET APCLJ=4
- Begin DoDot:1
- +9 IF ^TMP("APCL",$JOB,37)["not recorded"
- SET APCLJ=4
- QUIT
- +10 SET X=^TMP("APCL",$JOB,37)
- SET %DT=""
- DO ^%DT
- SET APCLI=Y
- SET X=$PIECE(^TMP("APCL",$JOB,20),"- ",2)
- SET %DT=""
- DO ^%DT
- SET X=$SELECT(Y>APCLI:3,1:4)
- +11 QUIT
- End DoDot:1
- QUIT APCLJ
- +12 SET APCLJ=4
- +13 QUIT APCLJ
- +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
