- BTIUPCC1 ; IHS/ITSC/LJF - IHS PCC OBJECTS ;06-Jan-2016 12:37;DU
- ;;1.0;TEXT INTEGRATION UTILITIES;**1002,1004,1005,1006,1010,1012,1013,1016**;NOV 04, 2004;Build 10
- ;IHS/ITSC/LJF 02/24/2005 PATCH 1002 - enhanced measurement display
- ; 04/14/2005 PATCH 1002 - fixed logic for last measurement on same day
- ; 01/26/2006 PATCH 1004 - Added fix for problem list w/o dates
- ; Fixed BMI logic
- ; Fixed logic for vitals for inpts
- ; Patch 1005 fixed formatting error on date for correct sorting
- ; Patch 1006 added classification for problems, skip entered in error vitals
- ; Patch 1010 added qualifiers
- ; Patch 1012 Problems changed for new statuses
- ; Patch 1016 added comments to problems
- LASTPRC(DFN,TIUICD,TIUPRC) ;EP -- returns date of last X procedure
- ;TIUICD=array of ICD procedure codes
- ;TIUPRC=phrase explaining type of procedures; used in output
- Q:'$G(DFN) Q:'$O(TIUICD(0)) Q:$G(TIUPRC)=""
- NEW PRCN,PRCDT,TIUARR,TIU
- ; -- loop thru all procedures for patient
- S PRCN=0 F S PRCN=$O(^AUPNVPRC("AC",DFN,PRCN)) Q:'PRCN D
- . K TIU D ENP^XBDIQ1(9000010.08,PRCN,".01;.03;.04;1201","TIU(","I")
- . I '$D(TIUICD(TIU(.01))) Q ;ICD code not on list
- . ;
- . ; -- get date: use event date if set, otherwise find visit date
- . S PRCDT=$S(TIU(1201,"I")]"":TIU(1201,"I"),1:$$GET1^DIQ(9000010,TIU(.03,"I"),.01,"I"))
- . ;
- . ; -- set array using date
- . S TIUARR(PRCDT)=TIU(.04)
- ;
- ; -- find most recent procedure from list
- S PRCDT=$O(TIUARR(""),-1) I 'PRCDT Q "No "_TIUPRC_" found"
- ;
- ; -- return caption, date and provider narrative
- Q "Last "_TIUPRC_": "_$$FMTE^XLFDT(PRCDT,"5D")_" ("_TIUARR(PRCDT)_")"
- ;
- ;
- LSTSK(DFN,TIUTST) ;EP; -- returns most current skin test for single test
- NEW SKT,VDT,IEN,X,TIU,LINE
- S SKT=$O(^AUTTSK("B",TIUTST,0)) I SKT="" Q ""
- S VDT=0
- F S VDT=$O(^AUPNVSK("AA",DFN,SKT,VDT)) Q:'VDT!($G(LINE)]"") D
- . S IEN=0
- . F S IEN=$O(^AUPNVSK("AA",DFN,SKT,VDT,IEN)) Q:'IEN!($G(LINE)]"") D
- .. K TIU D ENP^XBDIQ1(9000010.12,IEN,".03:.06","TIU(")
- .. I TIU(.04)="" S LINE="Placed on "_TIU(.03) Q
- .. S LINE=$$PAD($J(TIU(.04),12)_" "_TIU(.05),25)
- .. S LINE=LINE_"Date Read: "_TIU(.06)
- S X="Last "_$$PAD(TIUTST_":",12)
- Q X_$S($G(LINE)]"":LINE,1:" - Not Done -")
- ;
- LASTMSR(DFN,TIUMSR,TIUCAP,TIUDATE) ;EP; -- returns last measurement for patient
- ; TIUMSR=measurement name
- ; TIUCAP=1 if caption with measurement name is to be returned
- ; TIUDATE=1 return date measurement taken
- NEW LINE,X,VAIN
- ;Run different routine if patient is an inpatient
- ;Added in patch 4
- D INP^VADPT
- I $G(VAIN(1)) S LINE=$$LSTMEAS^BTIUPCC4(DFN,TIUMSR,.VAIN)
- I '$G(VAIN(1)) S LINE=$$LSTMEAS(DFN,TIUMSR)
- S X=$S($G(TIUCAP):"Last "_TIUMSR_": ",1:"")
- ;
- ;IHS/ITSC/LJF 02/24/2005 PATCH 1002 lines added to display more details
- NEW Y,RET,VMIEN
- I $P(LINE,U,2)="" Q X_$P(LINE,U)
- I TIUMSR="TMP" S Y=$P(LINE,U),Y=Y_" F ["_$J((Y-32)*(5/9),3,1)_" C]",$P(LINE,U)=Y
- I ((TIUMSR="HT")!(TIUMSR="HC")!(TIUMSR="WC")!(TIUMSR="AG")) S Y=$P(LINE,U),Y=$J(Y,5,2)_" in ["_$J((Y*2.54),5,2)_" cm]",$P(LINE,U)=Y
- I TIUMSR="WT" S Y=$P(LINE,U),Y=$J(Y,5,2)_" lb ["_$J((Y*.454),5,2)_" kg]",$P(LINE,U)=Y
- I TIUMSR="BMI" D
- .S VMIEN=$P(LINE,U,2)
- .S Y=$P(LINE,U),Y=$J(Y,5,2)
- .I $$PREG^BTIUPCC6(DFN,VMIEN)=1 S Y=Y_"*"
- .S $P(LINE,U)=Y
- I $P(LINE,U,4)="" S RET=X_$P(LINE,U)_$$LSTDATE($P(LINE,U,2),$P(LINE,U,3),$G(TIUDATE))
- I $P(LINE,U,4)'="" S RET=X_$P(LINE,U)_$$LSTDATE($P(LINE,U,2),$P(LINE,U,3),$G(TIUDATE))_" Qualifiers: "_$P(LINE,U,4)
- Q RET
- ;
- BMI(DFN,TIUCAP) ;EP -- returns BMI based on last ht and wt
- ; TIUCAP=1 if caption with measurement name is to be returned
- NEW HT,WT,H,W,BMI,X
- S BMI=$$LASTMSR($G(DFN),"BMI",0,0) I +BMI<1 Q ""
- ;S BMI=$J(BMI,0,2)
- ;S HT=$$LASTMSR($G(DFN),"HT",0,0) I HT<1 Q ""
- ;S WT=$$LASTMSR($G(DFN),"WT",0,0) I WT<1 Q ""
- ;S BMI=""
- ; -- "borrowed" code from APCHS9B1
- ;S W=(WT/5)*2.3,H=(HT*2.5),H=(H*H)/10000,BMI=(W/H),BMI=$J(BMI,4,1)
- ; -- PATCH 1004 changed logic to match BEH MEASUREMENT CONTROL FILE
- ;S WT=WT*.45359,HT=HT*.0254,HT=HT*HT,BMI=+$J(WT/HT,0,2)
- S X=$S($G(TIUCAP):"BMI: ",1:"")
- Q X_BMI
- ;
- LSTMEAS(DFN,TIUMSR) ; -- returns most current measurement (internal values)
- ;IHS/ITSC/LJF 04/`4/2005 PATCH 1002 rewrote logic to deal with >1 measurement per day
- NEW MSR,VDT,IEN,X,Y,TIU,LINE,ARR,DATE,STOP,QUALIF
- S MSR=$O(^AUTTMSR("B",TIUMSR,0)) I MSR="" Q ""
- ;
- ;S STOP=$O(^AUPNVMSR("AA",DFN,MSR,0))\1 ;stop at most recent date
- ;I 'STOP Q "none found" ;none to be found
- S VDT=0
- S LINE=""
- F S VDT=$O(^AUPNVMSR("AA",DFN,MSR,VDT)) Q:'VDT!(LINE'="") D
- . S IEN=0
- . F S IEN=$O(^AUPNVMSR("AA",DFN,MSR,VDT,IEN)) Q:'IEN D
- .. K TIU D ENP^XBDIQ1(9000010.01,IEN,".03;.04;2;1201","TIU(","I")
- .. ; value ^ visit ien ^ event date internal format
- .. Q:TIU(2,"I")=1 ;Quit if entered in error
- .. S LINE=$G(TIU(.04))_U_$G(TIU(.03,"I"))_U_$G(TIU(1201,"I"))
- .. ;I TIUMSR'="BP" S Y=$P(LINE,U),Y=$J(Y,5,2),$P(LINE,U)=Y
- .. S DATE=$S($G(TIU(1201,"I"))]"":TIU(1201,"I"),1:(9999999-$P(VDT,"."))_"."_$P(VDT,".",2))
- .. S QUALIF=$$QUAL^BTIULO7A(IEN)
- .. S ARR(DATE,IEN)=LINE_U_QUALIF_U_IEN
- ;
- I '$D(ARR) Q "None found"
- S DATE=$O(ARR(""),-1),IEN=$O(ARR(DATE,""),-1),LINE=ARR(DATE,IEN)
- Q $G(LINE)
- ;
- LSTDATE(DATE1,DATE2,YES) ;EP -- returns event date or visit date;PATCH 1002 fixed typo
- I 'YES Q "" ;no date asked for
- ;
- ;IHS/ITSC/LJF 02/24/2005 PATCH 1002 add parens around dates
- ;I $G(DATE2) Q " "_$$FMTE^XLFDT(DATE2) ;event date
- ;Q " "_$$GET1^DIQ(9000010,+DATE1,.01) ;visit date from visit ien
- I $G(DATE2) Q " ("_$$FMTE^XLFDT(DATE2)_")" ;event date
- I 'DATE1 Q " "
- ; IHS/MSC/MGH Patch 1005 changed to get date in upper and lower case for correct sorting
- N Y S Y=$$GET1^DIQ(9000010,+DATE1,.01,"I") ;visit date from visit ien
- Q " ("_$$FMTE^XLFDT(Y)_")" ;visit date from visit ien
- ;
- PROBLEM(DFN,STATUS,DATES,TARGET,COMMENT) ;EP -- returns the patient's problem list
- NEW PROB,CNT,LINE,MOD,ADD,CLASS,TXT,STAT,OLD,EXTRA,PCNT
- S CNT=0,OLD="",PCNT=0,COMMENT=$G(COMMENT)
- ;IHS/MSC/MGH PATCH 1012
- S STAT="" F S STAT=$O(^AUPNPROB("ACTIVE",DFN,STAT)) Q:STAT="" D
- .S PROB=0 F S PROB=$O(^AUPNPROB("ACTIVE",DFN,STAT,PROB)) Q:'PROB D
- .. Q:STAT="D"
- .. Q:STATUS'[STAT
- .. I OLD'=STAT D
- ... S OLD=STAT
- ... S TXT=$S(STAT="A":"Chronic",STAT="E":"Episodic",STAT="S":"Sub-Acute",STAT="O":"Social",1:"Inactive")
- ... S CNT=CNT+1
- ... S @TARGET@(CNT,0)=TXT_" Problems: "
- .. S LINE=$$GET1^DIQ(9000011,PROB,.05) ;prov narrative
- .. ;I $P(LINE,"|",1)["*" S LINE=$P(LINE,"|",2)
- .. S EXTRA=""
- .. I $L(LINE)>75 S EXTRA=$E(LINE,76,$L(LINE)),LINE=$E(LINE,1,75)
- .. S CNT=CNT+1,PCNT=PCNT+1
- .. S @TARGET@(CNT,0)=$J(PCNT,2)_")"_LINE
- .. I EXTRA'="" D
- ... S CNT=CNT+1
- ... S @TARGET@(CNT,0)=$$SP(5)_EXTRA
- .. S LINE=""
- .. S CLASS=$$GET1^DIQ(9000011,PROB,.15) ;Classification
- .. I CLASS'="" S LINE=" Classification: "_CLASS
- .. I DATES="D" D
- ... S ADD=$$GET1^DIQ(9000011,PROB,.08),MOD=$$GET1^DIQ(9000011,PROB,.03) ;dates added/modified
- ... S LINE=LINE_"("_$S(ADD=MOD:"Added on "_ADD,1:"Last update on "_MOD)_")"
- ... S CNT=CNT+1
- ... S @TARGET@(CNT,0)=$$SP(5)_LINE
- ..D QUAL^BTIUPV1(PROB,.CNT)
- ..I COMMENT=1 D NOTEDSP(PROB)
- I CNT=0 S @TARGET@(1,0)=$S(STATUS="A":"Chronic",STATUS="E":"Episodic",STATUS="S":"Sub-Acute",STATUS="O":"Social",STATUS="I":"Inactive",1:"Active")_" Problems: None Found"
- Q "~@"_$NA(@TARGET)
- ;
- UPDPROB(DFN,TARGET) ;EP; -- returns list of problems added or updated today
- NEW PROB,CNT,LINE,STATUS,ADD,MOD,CLASS
- F STATUS="A","E","S","O","I" D
- . S PROB=0 F S PROB=$O(^AUPNPROB("ACTIVE",DFN,STATUS,PROB)) Q:'PROB D
- .. S ADD=$$GET1^DIQ(9000011,PROB,.08,"I"),MOD=$$GET1^DIQ(9000011,PROB,.03,"I") ;dates added/modified (internal format)
- .. I (ADD'=DT)&(MOD'=DT) Q ;not added or updated today
- .. S CNT=$G(CNT)+1
- .. I CNT=1 S @TARGET@(1,0)="Problem List Updates: " S CNT=2
- .. S LINE=$$GET1^DIQ(9000011,PROB,.05)_" ["_STATUS_"] " ;prov narrative and status
- .. S CLASS=$$GET1^DIQ(9000011,PROB,.15) ;CLASSIFICATION
- .. I CLASS'="" S LINE=LINE_" Classification: "_LINE
- .. S LINE=LINE_" ("_$S(ADD=MOD:"Added",1:"Updated")_")"
- .. S @TARGET@(CNT,0)=$$SP(5)_LINE
- I '$G(CNT) S @TARGET@(1,0)="Problem List Updates: None Found"
- Q "~@"_$NA(@TARGET)
- ;
- PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
- Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
- ;
- SP(NUM) ; -- SUBRTN to pad spaces
- Q $$PAD(" ",NUM)
- NOTEDSP(PROB) ;Display notes for this problem
- N BTIUNFP,BTIUQ,SITE,BHSNAB,BTIUNDF,BHSITE,BFCN,BTIUN,BTIUNAR
- S BTIUNFP=0 F BTIUQ=0:0 S BTIUNFP=$O(^AUPNPROB(PROB,11,BTIUNFP)) Q:'BTIUNFP D DSPFACN
- Q
- DSPFACN ; DISPLAY NOTES FOR SELECTED FACILITY
- Q:$D(^AUPNPROB(PROB,11,BTIUNFP,11,0))'=1 Q:$O(^(0))=""
- S BHSITE=^AUPNPROB(PROB,11,BTIUNFP,0) D GETSITE^BHSUTL S BFCN=BHSNAB
- S BTIUNDF=0 F BTIUQ=0:0 S BTIUNDF=$O(^AUPNPROB(PROB,11,BTIUNFP,11,BTIUNDF)) Q:'BTIUNDF S BTIUN=^(BTIUNDF,0) D DSPN
- Q
- DSPN ; DISPLAY SINGLE NOTE
- N NTEDTE,TXT2,COMM,X,SUBCOUNT,SUBLINE
- Q:$P(BTIUN,U,4)="E"
- Q:$P(BTIUN,U,4)="I"
- S COMM=$P(BTIUN,U,3) S X=$P(BTIUN,U,5)
- I X>0 D REGDT4^GMTSU S NTEDTE=X
- F BTIUQ=0:0 Q:$E(BFCN)'=" " S BFCN=$E(BFCN,2,99)
- S CNT=CNT+1
- S @TARGET@(CNT,0)=" Note: "_BFCN_" "_$P(BTIUN,U)_" on "_NTEDTE
- S MAXLEN=60
- I $L(COMM)>MAXLEN D
- .S TXT2=$$WRAP^TIULS(COMM,MAXLEN)
- .F SUBCOUNT=1:1 S SUBLINE=$P(TXT2,"|",SUBCOUNT) Q:SUBLINE="" D ADD2(SUBLINE)
- E D ADD2(COMM)
- ADD2(TXT) ;
- S CNT=CNT+1
- S @TARGET@(CNT,0)=" "_TXT
- Q
- S BHSTXT=BHSNAR,BHSICL=34 D PRTTXT^BHSUTL
- Q
- BTIUPCC1 ; IHS/ITSC/LJF - IHS PCC OBJECTS ;06-Jan-2016 12:37;DU
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**1002,1004,1005,1006,1010,1012,1013,1016**;NOV 04, 2004;Build 10
- +2 ;IHS/ITSC/LJF 02/24/2005 PATCH 1002 - enhanced measurement display
- +3 ; 04/14/2005 PATCH 1002 - fixed logic for last measurement on same day
- +4 ; 01/26/2006 PATCH 1004 - Added fix for problem list w/o dates
- +5 ; Fixed BMI logic
- +6 ; Fixed logic for vitals for inpts
- +7 ; Patch 1005 fixed formatting error on date for correct sorting
- +8 ; Patch 1006 added classification for problems, skip entered in error vitals
- +9 ; Patch 1010 added qualifiers
- +10 ; Patch 1012 Problems changed for new statuses
- +11 ; Patch 1016 added comments to problems
- LASTPRC(DFN,TIUICD,TIUPRC) ;EP -- returns date of last X procedure
- +1 ;TIUICD=array of ICD procedure codes
- +2 ;TIUPRC=phrase explaining type of procedures; used in output
- +3 IF '$GET(DFN)
- QUIT
- IF '$ORDER(TIUICD(0))
- QUIT
- IF $GET(TIUPRC)=""
- QUIT
- +4 NEW PRCN,PRCDT,TIUARR,TIU
- +5 ; -- loop thru all procedures for patient
- +6 SET PRCN=0
- FOR
- SET PRCN=$ORDER(^AUPNVPRC("AC",DFN,PRCN))
- IF 'PRCN
- QUIT
- Begin DoDot:1
- +7 KILL TIU
- DO ENP^XBDIQ1(9000010.08,PRCN,".01;.03;.04;1201","TIU(","I")
- +8 ;ICD code not on list
- IF '$DATA(TIUICD(TIU(.01)))
- QUIT
- +9 ;
- +10 ; -- get date: use event date if set, otherwise find visit date
- +11 SET PRCDT=$SELECT(TIU(1201,"I")]"":TIU(1201,"I"),1:$$GET1^DIQ(9000010,TIU(.03,"I"),.01,"I"))
- +12 ;
- +13 ; -- set array using date
- +14 SET TIUARR(PRCDT)=TIU(.04)
- End DoDot:1
- +15 ;
- +16 ; -- find most recent procedure from list
- +17 SET PRCDT=$ORDER(TIUARR(""),-1)
- IF 'PRCDT
- QUIT "No "_TIUPRC_" found"
- +18 ;
- +19 ; -- return caption, date and provider narrative
- +20 QUIT "Last "_TIUPRC_": "_$$FMTE^XLFDT(PRCDT,"5D")_" ("_TIUARR(PRCDT)_")"
- +21 ;
- +22 ;
- LSTSK(DFN,TIUTST) ;EP; -- returns most current skin test for single test
- +1 NEW SKT,VDT,IEN,X,TIU,LINE
- +2 SET SKT=$ORDER(^AUTTSK("B",TIUTST,0))
- IF SKT=""
- QUIT ""
- +3 SET VDT=0
- +4 FOR
- SET VDT=$ORDER(^AUPNVSK("AA",DFN,SKT,VDT))
- IF 'VDT!($GET(LINE)]"")
- QUIT
- Begin DoDot:1
- +5 SET IEN=0
- +6 FOR
- SET IEN=$ORDER(^AUPNVSK("AA",DFN,SKT,VDT,IEN))
- IF 'IEN!($GET(LINE)]"")
- QUIT
- Begin DoDot:2
- +7 KILL TIU
- DO ENP^XBDIQ1(9000010.12,IEN,".03:.06","TIU(")
- +8 IF TIU(.04)=""
- SET LINE="Placed on "_TIU(.03)
- QUIT
- +9 SET LINE=$$PAD($JUSTIFY(TIU(.04),12)_" "_TIU(.05),25)
- +10 SET LINE=LINE_"Date Read: "_TIU(.06)
- End DoDot:2
- End DoDot:1
- +11 SET X="Last "_$$PAD(TIUTST_":",12)
- +12 QUIT X_$SELECT($GET(LINE)]"":LINE,1:" - Not Done -")
- +13 ;
- LASTMSR(DFN,TIUMSR,TIUCAP,TIUDATE) ;EP; -- returns last measurement for patient
- +1 ; TIUMSR=measurement name
- +2 ; TIUCAP=1 if caption with measurement name is to be returned
- +3 ; TIUDATE=1 return date measurement taken
- +4 NEW LINE,X,VAIN
- +5 ;Run different routine if patient is an inpatient
- +6 ;Added in patch 4
- +7 DO INP^VADPT
- +8 IF $GET(VAIN(1))
- SET LINE=$$LSTMEAS^BTIUPCC4(DFN,TIUMSR,.VAIN)
- +9 IF '$GET(VAIN(1))
- SET LINE=$$LSTMEAS(DFN,TIUMSR)
- +10 SET X=$SELECT($GET(TIUCAP):"Last "_TIUMSR_": ",1:"")
- +11 ;
- +12 ;IHS/ITSC/LJF 02/24/2005 PATCH 1002 lines added to display more details
- +13 NEW Y,RET,VMIEN
- +14 IF $PIECE(LINE,U,2)=""
- QUIT X_$PIECE(LINE,U)
- +15 IF TIUMSR="TMP"
- SET Y=$PIECE(LINE,U)
- SET Y=Y_" F ["_$JUSTIFY((Y-32)*(5/9),3,1)_" C]"
- SET $PIECE(LINE,U)=Y
- +16 IF ((TIUMSR="HT")!(TIUMSR="HC")!(TIUMSR="WC")!(TIUMSR="AG"))
- SET Y=$PIECE(LINE,U)
- SET Y=$JUSTIFY(Y,5,2)_" in ["_$JUSTIFY((Y*2.54),5,2)_" cm]"
- SET $PIECE(LINE,U)=Y
- +17 IF TIUMSR="WT"
- SET Y=$PIECE(LINE,U)
- SET Y=$JUSTIFY(Y,5,2)_" lb ["_$JUSTIFY((Y*.454),5,2)_" kg]"
- SET $PIECE(LINE,U)=Y
- +18 IF TIUMSR="BMI"
- Begin DoDot:1
- +19 SET VMIEN=$PIECE(LINE,U,2)
- +20 SET Y=$PIECE(LINE,U)
- SET Y=$JUSTIFY(Y,5,2)
- +21 IF $$PREG^BTIUPCC6(DFN,VMIEN)=1
- SET Y=Y_"*"
- +22 SET $PIECE(LINE,U)=Y
- End DoDot:1
- +23 IF $PIECE(LINE,U,4)=""
- SET RET=X_$PIECE(LINE,U)_$$LSTDATE($PIECE(LINE,U,2),$PIECE(LINE,U,3),$GET(TIUDATE))
- +24 IF $PIECE(LINE,U,4)'=""
- SET RET=X_$PIECE(LINE,U)_$$LSTDATE($PIECE(LINE,U,2),$PIECE(LINE,U,3),$GET(TIUDATE))_" Qualifiers: "_$PIECE(LINE,U,4)
- +25 QUIT RET
- +26 ;
- BMI(DFN,TIUCAP) ;EP -- returns BMI based on last ht and wt
- +1 ; TIUCAP=1 if caption with measurement name is to be returned
- +2 NEW HT,WT,H,W,BMI,X
- +3 SET BMI=$$LASTMSR($GET(DFN),"BMI",0,0)
- IF +BMI<1
- QUIT ""
- +4 ;S BMI=$J(BMI,0,2)
- +5 ;S HT=$$LASTMSR($G(DFN),"HT",0,0) I HT<1 Q ""
- +6 ;S WT=$$LASTMSR($G(DFN),"WT",0,0) I WT<1 Q ""
- +7 ;S BMI=""
- +8 ; -- "borrowed" code from APCHS9B1
- +9 ;S W=(WT/5)*2.3,H=(HT*2.5),H=(H*H)/10000,BMI=(W/H),BMI=$J(BMI,4,1)
- +10 ; -- PATCH 1004 changed logic to match BEH MEASUREMENT CONTROL FILE
- +11 ;S WT=WT*.45359,HT=HT*.0254,HT=HT*HT,BMI=+$J(WT/HT,0,2)
- +12 SET X=$SELECT($GET(TIUCAP):"BMI: ",1:"")
- +13 QUIT X_BMI
- +14 ;
- LSTMEAS(DFN,TIUMSR) ; -- returns most current measurement (internal values)
- +1 ;IHS/ITSC/LJF 04/`4/2005 PATCH 1002 rewrote logic to deal with >1 measurement per day
- +2 NEW MSR,VDT,IEN,X,Y,TIU,LINE,ARR,DATE,STOP,QUALIF
- +3 SET MSR=$ORDER(^AUTTMSR("B",TIUMSR,0))
- IF MSR=""
- QUIT ""
- +4 ;
- +5 ;S STOP=$O(^AUPNVMSR("AA",DFN,MSR,0))\1 ;stop at most recent date
- +6 ;I 'STOP Q "none found" ;none to be found
- +7 SET VDT=0
- +8 SET LINE=""
- +9 FOR
- SET VDT=$ORDER(^AUPNVMSR("AA",DFN,MSR,VDT))
- IF 'VDT!(LINE'="")
- QUIT
- Begin DoDot:1
- +10 SET IEN=0
- +11 FOR
- SET IEN=$ORDER(^AUPNVMSR("AA",DFN,MSR,VDT,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:2
- +12 KILL TIU
- DO ENP^XBDIQ1(9000010.01,IEN,".03;.04;2;1201","TIU(","I")
- +13 ; value ^ visit ien ^ event date internal format
- +14 ;Quit if entered in error
- IF TIU(2,"I")=1
- QUIT
- +15 SET LINE=$GET(TIU(.04))_U_$GET(TIU(.03,"I"))_U_$GET(TIU(1201,"I"))
- +16 ;I TIUMSR'="BP" S Y=$P(LINE,U),Y=$J(Y,5,2),$P(LINE,U)=Y
- +17 SET DATE=$SELECT($GET(TIU(1201,"I"))]"":TIU(1201,"I"),1:(9999999-$PIECE(VDT,"."))_"."_$PIECE(VDT,".",2))
- +18 SET QUALIF=$$QUAL^BTIULO7A(IEN)
- +19 SET ARR(DATE,IEN)=LINE_U_QUALIF_U_IEN
- End DoDot:2
- End DoDot:1
- +20 ;
- +21 IF '$DATA(ARR)
- QUIT "None found"
- +22 SET DATE=$ORDER(ARR(""),-1)
- SET IEN=$ORDER(ARR(DATE,""),-1)
- SET LINE=ARR(DATE,IEN)
- +23 QUIT $GET(LINE)
- +24 ;
- LSTDATE(DATE1,DATE2,YES) ;EP -- returns event date or visit date;PATCH 1002 fixed typo
- +1 ;no date asked for
- IF 'YES
- QUIT ""
- +2 ;
- +3 ;IHS/ITSC/LJF 02/24/2005 PATCH 1002 add parens around dates
- +4 ;I $G(DATE2) Q " "_$$FMTE^XLFDT(DATE2) ;event date
- +5 ;Q " "_$$GET1^DIQ(9000010,+DATE1,.01) ;visit date from visit ien
- +6 ;event date
- IF $GET(DATE2)
- QUIT " ("_$$FMTE^XLFDT(DATE2)_")"
- +7 IF 'DATE1
- QUIT " "
- +8 ; IHS/MSC/MGH Patch 1005 changed to get date in upper and lower case for correct sorting
- +9 ;visit date from visit ien
- NEW Y
- SET Y=$$GET1^DIQ(9000010,+DATE1,.01,"I")
- +10 ;visit date from visit ien
- QUIT " ("_$$FMTE^XLFDT(Y)_")"
- +11 ;
- PROBLEM(DFN,STATUS,DATES,TARGET,COMMENT) ;EP -- returns the patient's problem list
- +1 NEW PROB,CNT,LINE,MOD,ADD,CLASS,TXT,STAT,OLD,EXTRA,PCNT
- +2 SET CNT=0
- SET OLD=""
- SET PCNT=0
- SET COMMENT=$GET(COMMENT)
- +3 ;IHS/MSC/MGH PATCH 1012
- +4 SET STAT=""
- FOR
- SET STAT=$ORDER(^AUPNPROB("ACTIVE",DFN,STAT))
- IF STAT=""
- QUIT
- Begin DoDot:1
- +5 SET PROB=0
- FOR
- SET PROB=$ORDER(^AUPNPROB("ACTIVE",DFN,STAT,PROB))
- IF 'PROB
- QUIT
- Begin DoDot:2
- +6 IF STAT="D"
- QUIT
- +7 IF STATUS'[STAT
- QUIT
- +8 IF OLD'=STAT
- Begin DoDot:3
- +9 SET OLD=STAT
- +10 SET TXT=$SELECT(STAT="A":"Chronic",STAT="E":"Episodic",STAT="S":"Sub-Acute",STAT="O":"Social",1:"Inactive")
- +11 SET CNT=CNT+1
- +12 SET @TARGET@(CNT,0)=TXT_" Problems: "
- End DoDot:3
- +13 ;prov narrative
- SET LINE=$$GET1^DIQ(9000011,PROB,.05)
- +14 ;I $P(LINE,"|",1)["*" S LINE=$P(LINE,"|",2)
- +15 SET EXTRA=""
- +16 IF $LENGTH(LINE)>75
- SET EXTRA=$EXTRACT(LINE,76,$LENGTH(LINE))
- SET LINE=$EXTRACT(LINE,1,75)
- +17 SET CNT=CNT+1
- SET PCNT=PCNT+1
- +18 SET @TARGET@(CNT,0)=$JUSTIFY(PCNT,2)_")"_LINE
- +19 IF EXTRA'=""
- Begin DoDot:3
- +20 SET CNT=CNT+1
- +21 SET @TARGET@(CNT,0)=$$SP(5)_EXTRA
- End DoDot:3
- +22 SET LINE=""
- +23 ;Classification
- SET CLASS=$$GET1^DIQ(9000011,PROB,.15)
- +24 IF CLASS'=""
- SET LINE=" Classification: "_CLASS
- +25 IF DATES="D"
- Begin DoDot:3
- +26 ;dates added/modified
- SET ADD=$$GET1^DIQ(9000011,PROB,.08)
- SET MOD=$$GET1^DIQ(9000011,PROB,.03)
- +27 SET LINE=LINE_"("_$SELECT(ADD=MOD:"Added on "_ADD,1:"Last update on "_MOD)_")"
- +28 SET CNT=CNT+1
- +29 SET @TARGET@(CNT,0)=$$SP(5)_LINE
- End DoDot:3
- +30 DO QUAL^BTIUPV1(PROB,.CNT)
- +31 IF COMMENT=1
- DO NOTEDSP(PROB)
- End DoDot:2
- End DoDot:1
- +32 IF CNT=0
- SET @TARGET@(1,0)=$SELECT(STATUS="A":"Chronic",STATUS="E":"Episodic",STATUS="S":"Sub-Acute",STATUS="O":"Social",STATUS="I":"Inactive",1:"Active")_" Problems: None Found"
- +33 QUIT "~@"_$NAME(@TARGET)
- +34 ;
- UPDPROB(DFN,TARGET) ;EP; -- returns list of problems added or updated today
- +1 NEW PROB,CNT,LINE,STATUS,ADD,MOD,CLASS
- +2 FOR STATUS="A","E","S","O","I"
- Begin DoDot:1
- +3 SET PROB=0
- FOR
- SET PROB=$ORDER(^AUPNPROB("ACTIVE",DFN,STATUS,PROB))
- IF 'PROB
- QUIT
- Begin DoDot:2
- +4 ;dates added/modified (internal format)
- SET ADD=$$GET1^DIQ(9000011,PROB,.08,"I")
- SET MOD=$$GET1^DIQ(9000011,PROB,.03,"I")
- +5 ;not added or updated today
- IF (ADD'=DT)&(MOD'=DT)
- QUIT
- +6 SET CNT=$GET(CNT)+1
- +7 IF CNT=1
- SET @TARGET@(1,0)="Problem List Updates: "
- SET CNT=2
- +8 ;prov narrative and status
- SET LINE=$$GET1^DIQ(9000011,PROB,.05)_" ["_STATUS_"] "
- +9 ;CLASSIFICATION
- SET CLASS=$$GET1^DIQ(9000011,PROB,.15)
- +10 IF CLASS'=""
- SET LINE=LINE_" Classification: "_LINE
- +11 SET LINE=LINE_" ("_$SELECT(ADD=MOD:"Added",1:"Updated")_")"
- +12 SET @TARGET@(CNT,0)=$$SP(5)_LINE
- End DoDot:2
- End DoDot:1
- +13 IF '$GET(CNT)
- SET @TARGET@(1,0)="Problem List Updates: None Found"
- +14 QUIT "~@"_$NAME(@TARGET)
- +15 ;
- PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
- +1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
- +2 ;
- SP(NUM) ; -- SUBRTN to pad spaces
- +1 QUIT $$PAD(" ",NUM)
- NOTEDSP(PROB) ;Display notes for this problem
- +1 NEW BTIUNFP,BTIUQ,SITE,BHSNAB,BTIUNDF,BHSITE,BFCN,BTIUN,BTIUNAR
- +2 SET BTIUNFP=0
- FOR BTIUQ=0:0
- SET BTIUNFP=$ORDER(^AUPNPROB(PROB,11,BTIUNFP))
- IF 'BTIUNFP
- QUIT
- DO DSPFACN
- +3 QUIT
- DSPFACN ; DISPLAY NOTES FOR SELECTED FACILITY
- +1 IF $DATA(^AUPNPROB(PROB,11,BTIUNFP,11,0))'=1
- QUIT
- IF $ORDER(^(0))=""
- QUIT
- +2 SET BHSITE=^AUPNPROB(PROB,11,BTIUNFP,0)
- DO GETSITE^BHSUTL
- SET BFCN=BHSNAB
- +3 SET BTIUNDF=0
- FOR BTIUQ=0:0
- SET BTIUNDF=$ORDER(^AUPNPROB(PROB,11,BTIUNFP,11,BTIUNDF))
- IF 'BTIUNDF
- QUIT
- SET BTIUN=^(BTIUNDF,0)
- DO DSPN
- +4 QUIT
- DSPN ; DISPLAY SINGLE NOTE
- +1 NEW NTEDTE,TXT2,COMM,X,SUBCOUNT,SUBLINE
- +2 IF $PIECE(BTIUN,U,4)="E"
- QUIT
- +3 IF $PIECE(BTIUN,U,4)="I"
- QUIT
- +4 SET COMM=$PIECE(BTIUN,U,3)
- SET X=$PIECE(BTIUN,U,5)
- +5 IF X>0
- DO REGDT4^GMTSU
- SET NTEDTE=X
- +6 FOR BTIUQ=0:0
- IF $EXTRACT(BFCN)'=" "
- QUIT
- SET BFCN=$EXTRACT(BFCN,2,99)
- +7 SET CNT=CNT+1
- +8 SET @TARGET@(CNT,0)=" Note: "_BFCN_" "_$PIECE(BTIUN,U)_" on "_NTEDTE
- +9 SET MAXLEN=60
- +10 IF $LENGTH(COMM)>MAXLEN
- Begin DoDot:1
- +11 SET TXT2=$$WRAP^TIULS(COMM,MAXLEN)
- +12 FOR SUBCOUNT=1:1
- SET SUBLINE=$PIECE(TXT2,"|",SUBCOUNT)
- IF SUBLINE=""
- QUIT
- DO ADD2(SUBLINE)
- End DoDot:1
- +13 IF '$TEST
- DO ADD2(COMM)
- ADD2(TXT) ;
- +1 SET CNT=CNT+1
- +2 SET @TARGET@(CNT,0)=" "_TXT
- +3 QUIT
- +4 SET BHSTXT=BHSNAR
- SET BHSICL=34
- DO PRTTXT^BHSUTL
- +5 QUIT
