BTIUPCC3 ;IHS/CIA/MGH - TIU Object Support ;25-Nov-2015 10:33;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1003,1004,1005,1006,1012,1013,1015**;NOV 04,2004;Build 3
;IHS/CIA/MGH New routine for objects added for TIU use
;Patch 1006 incorporated reproductive history field changes
REPRO(DFN,TARGET,MODE) ;EP Return reproductive history
N TOT,GRAV,CNT,PARA,LC,SA,TA,X,OTHER,BTIUN,BTIUM,G,MB,FT,PRE,EC
K @TARGET
I $P(^DPT(DFN,0),U,2)="M" S @TARGET@(1,0)="Patient is male" G END
I '$D(^AUPNREP(DFN,0)) S @TARGET@(1,0)="No history on file" G END
S BTIUN=$G(^AUPNREP(DFN,0))
S G=$$GET1^DIQ(9000017,+$G(DFN),1103)
;I G="" D OLD
;E D NEW
D NEW
END Q "~@"_$NA(@TARGET)
NEW ;Get the reproductive history using the new fields
S MB=$$GET1^DIQ(9000017,+$G(DFN),1105)
S FT=$$GET1^DIQ(9000017,+$G(DFN),1107)
S PRE=$$GET1^DIQ(9000017,+$G(DFN),1109)
S EC=$$GET1^DIQ(9000017,+$G(DFN),1111)
S LC=$$GET1^DIQ(9000017,+$G(DFN),1113)
S TA=$$GET1^DIQ(9000017,+$G(DFN),1131)
S SA=$$GET1^DIQ(9000017,+$G(DFN),1133)
S CNT=1
S @TARGET@(CNT,0)="Gravida: "_G
S CNT=CNT+1
S @TARGET@(CNT,0)="Multiple Births: "_MB
S CNT=CNT+1
S @TARGET@(CNT,0)="Full Term: "_FT
S CNT=CNT+1
S @TARGET@(CNT,0)="Premature Births: "_PRE
S CNT=CNT+1
S @TARGET@(CNT,0)="Ectopics: "_EC
S CNT=CNT+1
S @TARGET@(CNT,0)="Living Children: "_LC
S CNT=CNT+1
S @TARGET@(CNT,0)="Theraputic Abortions: "_TA
S CNT=CNT+1
S @TARGET@(CNT,0)="Spontaneous Abortions: "_SA
D CONT(MODE)
Q
OLD ;Get the reproductive history using the old fields
S X=$P(BTIUN,U,2)
;Patch 1005 upgraded the reproductive history
I X]"" D
.S GRAV=$P(X,"P",1),OTHER=$P(X,"P",2)
.S PARA=$P(OTHER,"LC",1),OTHER=$P(OTHER,"LC",2)
.S LC=$P(OTHER,"SA",1),OTHER=$P(OTHER,"SA",2)
.S SA=$P(OTHER,"TA",1),OTHER=$P(OTHER,"TA",2)
.S TA=OTHER
.S TOT=GRAV_" P"_PARA_" LC"_LC_" SA"_SA_" TA"_TA
.S CNT=1
.S @TARGET@(CNT,0)=TOT_" (obtained on, "_$$GET1^DIQ(9000017,+$G(DFN),1.1)_")"
.S X=$P(BTIUN,U,4) S:X="" X="<LMP not recorded>"
.I +X S X="LMP: "_$$GET1^DIQ(9000017,+$G(DFN),2)_" (recorded on, "_$$GET1^DIQ(9000017,+$G(DFN),2.1)_")"
.S CNT=CNT+1
.S @TARGET@(CNT,0)=X
.D LMP
Q
LMP ;Get the LMP data
N FPBEGIN,FPDATE
S X=$$GET1^DIQ(9000017,+$G(DFN),3)
S CNT=CNT+1
I X="" D
.S @TARGET@(CNT,0)="FP METHOD: "_$S(X="":"None Recorded",1:X)
E D
.S FPBEGIN=$$GET1^DIQ(9000017,DFN,3.05),FPDATE=$$GET1^DIQ(9000017,DFN,3.1)
.S @TARGET@(CNT,0)="FP METHOD: "_X_" (begun "_FPBEGIN_"; recorded "_FPDATE_")"
.S X=$P(BTIUN,U,9) I X]"" D EDC
Q
EDC NEW X,HOW,EDCDT
S X=$$GET1^DIQ(9000017,+$G(DFN),4)
S CNT=CNT+1
I X="" S @TARGET@(CNT,0)="EDC: "_$S(X="":"None Recorded",1:X) Q
S HOW=$$GET1^DIQ(9000017,+DFN,4.05),EDCDT=$$GET1^DIQ(9000017,DFN,4.1)
S @TARGET@(CNT,0)="EDC: "_X_" (determined by "_$S(HOW="":"UNKNOWN METHOD",1:HOW)_" on "_EDCDT_")"
Q
SURG(DFN,DATE) ;EP
; returns multi-line listing of patient's surgical history;PATC
; If DATE=1, return date each item obtained
NEW COUNT,TIUX,LINE,TIUA,BTIUIVD,BTIUSQ,BTIUDFN,BHSICD
S COUNT=0
K ^TMP("BTIUPCC3",$J)
;
; for this patient, find all surgical history entries
S TIUX=0,LINE=""
I '$D(^AUPNVPRC("AC",DFN)) S ^TMP("BTIUPCC3",$J,1,0)="No procedures found for pt"
S COUNT=0
S BTIUIVD=0 F BTIUSQ=0:0 S BTIUIVD=$O(^AUPNVPRC("AA",DFN,BTIUIVD)) Q:'BTIUIVD D
.S BTIUDFN=0 F BTIUDFN=0:0 S BTIUDFN=$O(^AUPNVPRC("AA",DFN,BTIUIVD,BTIUDFN)) Q:'BTIUDFN D
..K TIUA D ENP^XBDIQ1(9000010.08,BTIUDFN,".01:.04","TIUA(")
..D HOSCHK
..I BHSICD'="" D
...S LINE=TIUA(.04)_" ["_TIUA(.019)_"]" ;prov narrative [ICD dx code]
...I $G(DATE) S LINE=LINE_" - "_TIUA(.03) ;date noted
...S COUNT=$G(COUNT)+1 S ^TMP("BTIUPCC3",$J,COUNT,0)=LINE
;
;Check for surgical CPT codes
S BTIUIVD=0 F S BTIUIVD=$O(^AUPNVCPT("C",DFN,BTIUIVD)) Q:'BTIUIVD D
.D CHKCPT
I '$D(^TMP("BTIUPCC3",$J)) Q "No Surgical History Found for Patient"
Q "~@^TMP(""BTIUPCC3"",$J)"
HOSCHK ;
;Check for real surgical codes
;Patch 1013 changed to check icd9 and icd-10 in taxonomy
N TAXIEN,ARRAY
;Patch 1015 Find minor procedure using API
I $$ICD^ATXAPI(TIUA(.01),$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S BHSICD="" Q
;I TIUA(.01)>85 S BHSICD="" Q
;I TIUA(.01)=69.7 S BHSICD="" Q
;I TIUA(.01)\1=23 S BHSICD="" Q
;I TIUA(.01)\1=24 S BHSICD="" Q
;I $E(TIUA(.01),1,4)="38.9" S BHSICD="" Q
E S BHSICD=1
Q
CHKCPT ;Check for surgical CPT codes
N REC,CPTIEN,CODE
S REC=$G(^AUPNVCPT(BTIUIVD,0)) Q:REC=""
S CPTIEN=$P(REC,U) Q:CPTIEN=""
S CODE=$P($G(^ICPT(CPTIEN,0)),U) Q:CODE=""
I ((CODE<10000)&(CODE'="00099"))!(CODE>69999) Q
N TAXIEN,ARRAY2
;Patch 1015 added call to API to check
I $$ICD^ATXAPI(CPTIEN,$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0)),1) D
.K TIUA D ENP^XBDIQ1(9000010.18,BTIUIVD,".01:.04","TIUA(")
.;I TIUA(.04)="" Q
.S LINE=TIUA(.04)_" ["_TIUA(.019)_"]" ;prov narrative [ICD dx cod
.I $G(DATE) S LINE=LINE_" - "_TIUA(.03) ;date noted
.S COUNT=$G(COUNT)+1 S ^TMP("BTIUPCC3",$J,COUNT,0)=LINE
Q
CONT(MODE) ;Get contraception data
N BHX,BHC,TYP,START,END,LINE,CCNT,LIN1
S CCNT=0
S CNT=CNT+1 S @TARGET@(CNT,0)="FP METHOD: "
S BHX=0 F S BHX=$O(^AUPNREP(DFN,2101,BHX)) Q:BHX'=+BHX D
.Q:$D(^AUPNREP(DFN,2101,BHX,1))>0
.S BHC=$P(^AUPNREP(DFN,2101,BHX,0),U,1) I BHC D
..S TYP=$P(^AUTTCM(BHC,0),U)
..S START=$P(^AUPNREP(DFN,2101,BHX,0),U,2) I START]"" S START=$$FIXDT^BHSFAM1(START)
..S END=$P(^AUPNREP(DFN,2101,BHX,0),U,3) I END]"" S END=$$FIXDT^BHSFAM1(END)
..S LINE=$S(TYP="":"None Recorded",1:TYP)
..I MODE="A"&(END="") D
...S CNT=CNT+1,CCNT=CCNT+1
...S LINE=" "_LINE_" Start Dt: "_START
...S @TARGET@(CNT,0)=LINE
..I MODE="C" D
...S CNT=CNT+1,CCNT=CCNT+1
...S LINE=" "_LINE_" Start Dt: "_START
...S @TARGET@(CNT,0)=LINE
...I END'="" D
....S CNT=CNT+1,CCNT=CCNT+1
....S LIN1=""
....I $P(^AUPNREP(DFN,2101,BHX,0),U,5)]"" S LIN1=" Reason Discontinued: "_$P(^AUPNREP(DFN,2101,BHX,0),U,5)
....S @TARGET@(CNT,0)=" End Dt: "_END_LIN1
Q
BTIUPCC3 ;IHS/CIA/MGH - TIU Object Support ;25-Nov-2015 10:33;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1003,1004,1005,1006,1012,1013,1015**;NOV 04,2004;Build 3
+2 ;IHS/CIA/MGH New routine for objects added for TIU use
+3 ;Patch 1006 incorporated reproductive history field changes
REPRO(DFN,TARGET,MODE) ;EP Return reproductive history
+1 NEW TOT,GRAV,CNT,PARA,LC,SA,TA,X,OTHER,BTIUN,BTIUM,G,MB,FT,PRE,EC
+2 KILL @TARGET
+3 IF $PIECE(^DPT(DFN,0),U,2)="M"
SET @TARGET@(1,0)="Patient is male"
GOTO END
+4 IF '$DATA(^AUPNREP(DFN,0))
SET @TARGET@(1,0)="No history on file"
GOTO END
+5 SET BTIUN=$GET(^AUPNREP(DFN,0))
+6 SET G=$$GET1^DIQ(9000017,+$GET(DFN),1103)
+7 ;I G="" D OLD
+8 ;E D NEW
+9 DO NEW
END QUIT "~@"_$NAME(@TARGET)
NEW ;Get the reproductive history using the new fields
+1 SET MB=$$GET1^DIQ(9000017,+$GET(DFN),1105)
+2 SET FT=$$GET1^DIQ(9000017,+$GET(DFN),1107)
+3 SET PRE=$$GET1^DIQ(9000017,+$GET(DFN),1109)
+4 SET EC=$$GET1^DIQ(9000017,+$GET(DFN),1111)
+5 SET LC=$$GET1^DIQ(9000017,+$GET(DFN),1113)
+6 SET TA=$$GET1^DIQ(9000017,+$GET(DFN),1131)
+7 SET SA=$$GET1^DIQ(9000017,+$GET(DFN),1133)
+8 SET CNT=1
+9 SET @TARGET@(CNT,0)="Gravida: "_G
+10 SET CNT=CNT+1
+11 SET @TARGET@(CNT,0)="Multiple Births: "_MB
+12 SET CNT=CNT+1
+13 SET @TARGET@(CNT,0)="Full Term: "_FT
+14 SET CNT=CNT+1
+15 SET @TARGET@(CNT,0)="Premature Births: "_PRE
+16 SET CNT=CNT+1
+17 SET @TARGET@(CNT,0)="Ectopics: "_EC
+18 SET CNT=CNT+1
+19 SET @TARGET@(CNT,0)="Living Children: "_LC
+20 SET CNT=CNT+1
+21 SET @TARGET@(CNT,0)="Theraputic Abortions: "_TA
+22 SET CNT=CNT+1
+23 SET @TARGET@(CNT,0)="Spontaneous Abortions: "_SA
+24 DO CONT(MODE)
+25 QUIT
OLD ;Get the reproductive history using the old fields
+1 SET X=$PIECE(BTIUN,U,2)
+2 ;Patch 1005 upgraded the reproductive history
+3 IF X]""
Begin DoDot:1
+4 SET GRAV=$PIECE(X,"P",1)
SET OTHER=$PIECE(X,"P",2)
+5 SET PARA=$PIECE(OTHER,"LC",1)
SET OTHER=$PIECE(OTHER,"LC",2)
+6 SET LC=$PIECE(OTHER,"SA",1)
SET OTHER=$PIECE(OTHER,"SA",2)
+7 SET SA=$PIECE(OTHER,"TA",1)
SET OTHER=$PIECE(OTHER,"TA",2)
+8 SET TA=OTHER
+9 SET TOT=GRAV_" P"_PARA_" LC"_LC_" SA"_SA_" TA"_TA
+10 SET CNT=1
+11 SET @TARGET@(CNT,0)=TOT_" (obtained on, "_$$GET1^DIQ(9000017,+$GET(DFN),1.1)_")"
+12 SET X=$PIECE(BTIUN,U,4)
IF X=""
SET X="<LMP not recorded>"
+13 IF +X
SET X="LMP: "_$$GET1^DIQ(9000017,+$GET(DFN),2)_" (recorded on, "_$$GET1^DIQ(9000017,+$GET(DFN),2.1)_")"
+14 SET CNT=CNT+1
+15 SET @TARGET@(CNT,0)=X
+16 DO LMP
End DoDot:1
+17 QUIT
LMP ;Get the LMP data
+1 NEW FPBEGIN,FPDATE
+2 SET X=$$GET1^DIQ(9000017,+$GET(DFN),3)
+3 SET CNT=CNT+1
+4 IF X=""
Begin DoDot:1
+5 SET @TARGET@(CNT,0)="FP METHOD: "_$SELECT(X="":"None Recorded",1:X)
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET FPBEGIN=$$GET1^DIQ(9000017,DFN,3.05)
SET FPDATE=$$GET1^DIQ(9000017,DFN,3.1)
+8 SET @TARGET@(CNT,0)="FP METHOD: "_X_" (begun "_FPBEGIN_"; recorded "_FPDATE_")"
+9 SET X=$PIECE(BTIUN,U,9)
IF X]""
DO EDC
End DoDot:1
+10 QUIT
EDC NEW X,HOW,EDCDT
+1 SET X=$$GET1^DIQ(9000017,+$GET(DFN),4)
+2 SET CNT=CNT+1
+3 IF X=""
SET @TARGET@(CNT,0)="EDC: "_$SELECT(X="":"None Recorded",1:X)
QUIT
+4 SET HOW=$$GET1^DIQ(9000017,+DFN,4.05)
SET EDCDT=$$GET1^DIQ(9000017,DFN,4.1)
+5 SET @TARGET@(CNT,0)="EDC: "_X_" (determined by "_$SELECT(HOW="":"UNKNOWN METHOD",1:HOW)_" on "_EDCDT_")"
+6 QUIT
SURG(DFN,DATE) ;EP
+1 ; returns multi-line listing of patient's surgical history;PATC
+2 ; If DATE=1, return date each item obtained
+3 NEW COUNT,TIUX,LINE,TIUA,BTIUIVD,BTIUSQ,BTIUDFN,BHSICD
+4 SET COUNT=0
+5 KILL ^TMP("BTIUPCC3",$JOB)
+6 ;
+7 ; for this patient, find all surgical history entries
+8 SET TIUX=0
SET LINE=""
+9 IF '$DATA(^AUPNVPRC("AC",DFN))
SET ^TMP("BTIUPCC3",$JOB,1,0)="No procedures found for pt"
+10 SET COUNT=0
+11 SET BTIUIVD=0
FOR BTIUSQ=0:0
SET BTIUIVD=$ORDER(^AUPNVPRC("AA",DFN,BTIUIVD))
IF 'BTIUIVD
QUIT
Begin DoDot:1
+12 SET BTIUDFN=0
FOR BTIUDFN=0:0
SET BTIUDFN=$ORDER(^AUPNVPRC("AA",DFN,BTIUIVD,BTIUDFN))
IF 'BTIUDFN
QUIT
Begin DoDot:2
+13 KILL TIUA
DO ENP^XBDIQ1(9000010.08,BTIUDFN,".01:.04","TIUA(")
+14 DO HOSCHK
+15 IF BHSICD'=""
Begin DoDot:3
+16 ;prov narrative [ICD dx code]
SET LINE=TIUA(.04)_" ["_TIUA(.019)_"]"
+17 ;date noted
IF $GET(DATE)
SET LINE=LINE_" - "_TIUA(.03)
+18 SET COUNT=$GET(COUNT)+1
SET ^TMP("BTIUPCC3",$JOB,COUNT,0)=LINE
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 ;Check for surgical CPT codes
+21 SET BTIUIVD=0
FOR
SET BTIUIVD=$ORDER(^AUPNVCPT("C",DFN,BTIUIVD))
IF 'BTIUIVD
QUIT
Begin DoDot:1
+22 DO CHKCPT
End DoDot:1
+23 IF '$DATA(^TMP("BTIUPCC3",$JOB))
QUIT "No Surgical History Found for Patient"
+24 QUIT "~@^TMP(""BTIUPCC3"",$J)"
HOSCHK ;
+1 ;Check for real surgical codes
+2 ;Patch 1013 changed to check icd9 and icd-10 in taxonomy
+3 NEW TAXIEN,ARRAY
+4 ;Patch 1015 Find minor procedure using API
+5 IF $$ICD^ATXAPI(TIUA(.01),$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
SET BHSICD=""
QUIT
+6 ;I TIUA(.01)>85 S BHSICD="" Q
+7 ;I TIUA(.01)=69.7 S BHSICD="" Q
+8 ;I TIUA(.01)\1=23 S BHSICD="" Q
+9 ;I TIUA(.01)\1=24 S BHSICD="" Q
+10 ;I $E(TIUA(.01),1,4)="38.9" S BHSICD="" Q
+11 IF '$TEST
SET BHSICD=1
+12 QUIT
CHKCPT ;Check for surgical CPT codes
+1 NEW REC,CPTIEN,CODE
+2 SET REC=$GET(^AUPNVCPT(BTIUIVD,0))
IF REC=""
QUIT
+3 SET CPTIEN=$PIECE(REC,U)
IF CPTIEN=""
QUIT
+4 SET CODE=$PIECE($GET(^ICPT(CPTIEN,0)),U)
IF CODE=""
QUIT
+5 IF ((CODE<10000)&(CODE'="00099"))!(CODE>69999)
QUIT
+6 NEW TAXIEN,ARRAY2
+7 ;Patch 1015 added call to API to check
+8 IF $$ICD^ATXAPI(CPTIEN,$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0)),1)
Begin DoDot:1
+9 KILL TIUA
DO ENP^XBDIQ1(9000010.18,BTIUIVD,".01:.04","TIUA(")
+10 ;I TIUA(.04)="" Q
+11 ;prov narrative [ICD dx cod
SET LINE=TIUA(.04)_" ["_TIUA(.019)_"]"
+12 ;date noted
IF $GET(DATE)
SET LINE=LINE_" - "_TIUA(.03)
+13 SET COUNT=$GET(COUNT)+1
SET ^TMP("BTIUPCC3",$JOB,COUNT,0)=LINE
End DoDot:1
+14 QUIT
CONT(MODE) ;Get contraception data
+1 NEW BHX,BHC,TYP,START,END,LINE,CCNT,LIN1
+2 SET CCNT=0
+3 SET CNT=CNT+1
SET @TARGET@(CNT,0)="FP METHOD: "
+4 SET BHX=0
FOR
SET BHX=$ORDER(^AUPNREP(DFN,2101,BHX))
IF BHX'=+BHX
QUIT
Begin DoDot:1
+5 IF $DATA(^AUPNREP(DFN,2101,BHX,1))>0
QUIT
+6 SET BHC=$PIECE(^AUPNREP(DFN,2101,BHX,0),U,1)
IF BHC
Begin DoDot:2
+7 SET TYP=$PIECE(^AUTTCM(BHC,0),U)
+8 SET START=$PIECE(^AUPNREP(DFN,2101,BHX,0),U,2)
IF START]""
SET START=$$FIXDT^BHSFAM1(START)
+9 SET END=$PIECE(^AUPNREP(DFN,2101,BHX,0),U,3)
IF END]""
SET END=$$FIXDT^BHSFAM1(END)
+10 SET LINE=$SELECT(TYP="":"None Recorded",1:TYP)
+11 IF MODE="A"&(END="")
Begin DoDot:3
+12 SET CNT=CNT+1
SET CCNT=CCNT+1
+13 SET LINE=" "_LINE_" Start Dt: "_START
+14 SET @TARGET@(CNT,0)=LINE
End DoDot:3
+15 IF MODE="C"
Begin DoDot:3
+16 SET CNT=CNT+1
SET CCNT=CCNT+1
+17 SET LINE=" "_LINE_" Start Dt: "_START
+18 SET @TARGET@(CNT,0)=LINE
+19 IF END'=""
Begin DoDot:4
+20 SET CNT=CNT+1
SET CCNT=CCNT+1
+21 SET LIN1=""
+22 IF $PIECE(^AUPNREP(DFN,2101,BHX,0),U,5)]""
SET LIN1=" Reason Discontinued: "_$PIECE(^AUPNREP(DFN,2101,BHX,0),U,5)
+23 SET @TARGET@(CNT,0)=" End Dt: "_END_LIN1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
