BTIUPCC3.m

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