- BTIUMED3 ; SLC/JM - Active/Recent Med Objects Routine ;30-Jul-2010 09:07;MGH
- ;;1.0;TEXT INTEGRATION UTILITIES;**1006**;Jun 20, 1997
- ;Object for last class medications
- Q
- LIST(DFN,BTIUMED,TARGET,CNT) ; EP
- ;
- ;
- ;
- ;Required Parameters:
- ;
- ; DFN Patient identifier
- ; BTIUMED The drug class to search
- ;
- ; TARGET Where the medication data will be stored
- ; CNT The number to return
- ;
- ;
- N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
- N INPTYPE,OUTPTYPE,TYPE,MEDTYPE,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST,REASON,REFILLS
- N LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,COUNTER,EVENT,HIEN,IEN
- N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,IDX,ID,CLININC
- N %,%H,STOP,LSTFD,ARRAY ;Clean up after external calls...
- S (NEXTLINE,TAB,HEADER,UNKNOWNS,CLININC)=0,LLEN=47
- K @TARGET,^TMP("PS",$J),ARRAY
- S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient?
- I ISINP S INPTYPE=1,OUTPTYPE=2
- E S INPTYPE=2,OUTPTYPE=1
- ;
- ; *** Scan medication data and skip unwanted meds ***
- ;
- S DAYS=180,ACTVONLY=0,ONELIST=0,DETAILED=1
- I '$D(CNT)=CNT=1
- D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
- S INDEX=0
- F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
- .S NODE=$G(^TMP("PS",$J,INDEX,0))
- .S CHRONIC=""
- .S STATUS=$P(NODE,U,9)
- .S IDATE=$P(NODE,U,15)
- .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
- .I $P($P(NODE,U),";",2)["O" D
- ..S RXNO=+($P(NODE,U,1))
- ..S CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)
- ..I STATUS="EXPIRED" D
- ...N X1,X2,X
- ...I CHRONIC S X1=DT,X2=-120 D C^%DTC S LDATE=X
- ...E S X1=DT,X2=-14 D C^%DTC S LDATE=X
- ...S EXDATE=$P($G(^PSRX(RXNO,2)),U,6)
- ...I EXDATE>LDATE S KEEPMED=1
- ..I STATUS="DISCONTINUED" D
- ...S X1=DT,X2=-30 D C^%DTC S LDATE=X
- ...S CANDATE=$P($G(^PSRX(RXNO,3)),U,5)
- ...I CANDATE>LDATE S KEEPMED=1
- .I STATUS="PENDING" D
- ..S IEN=+($P(NODE,U))
- ..I IEN>0 S REFILLS=$P($G(^PS(52.41,IEN,0)),U,11)
- ..S $P(^TMP("PS",$J,INDEX,0),U,5)=REFILLS
- .S TYPE=$P($P(NODE,U),";",2)
- .S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
- .S KEEPMED=(TYPE'="")
- .I KEEPMED D
- ..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV"
- ..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV"
- ..I TYPE="OP" S MEDTYPE=OUTPTYPE
- ..E S MEDTYPE=INPTYPE
- ..I MEDTYPE=INPTYPE S KEEPMED=ISINP
- ..E S KEEPMED='ISINP
- .S DRUGCLAS=" "
- .S MED=$P(NODE,U,2)
- .I KEEPMED D
- ..S DRUGIDX=$O(^PSDRUG("B",MED,0))
- ..D GETCLASS(BTIUMED)
- ..I BTIUMED'=DRUGCLAS S KEEPMED=0
- ..I KEEPMED D
- ...N ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
- ...S ID=$P(NODE,U)
- ...S IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
- ...S (DRUGIDX,ORDIDX)=0
- ...I ID="R;O" S DRUGIDX=+$P($G(^PSRX(IDX,0)),U,6)
- ...I ID="P;O" S DRUGIDX=+$P($G(^PS(52.41,IDX,0)),U,9)
- ...I ID="P;I" D
- ....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D
- .....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
- ...I ID="U;I" D
- ....I $P($G(^PS(55,DFN,5,IDX,1,0)),U,4)=1 D
- .....S TMPIDX=$O(^PS(55,DFN,5,IDX,1,0)) I +TMPIDX S DRUGIDX=$P($G(^PS(55,DFN,5,IDX,1,TMPIDX,0)),U)
- ...I ID="V;I" D
- ....I $P($G(^PS(55,DFN,"IV",IDX,"AD",0)),U,4)=1 D
- .....S TMPIDX=$O(^PS(55,DFN,"IV",IDX,"AD",0)) I +TMPIDX D
- ......S TMPIDX=$P($G(^PS(55,DFN,"IV",IDX,"AD",TMPIDX,0)),U)
- ......I +TMPIDX S DRUGIDX=$P($G(^PS(52.6,TMPIDX,0)),U,2)
- .; *** Save wanted meds in "B" temp xref, removing duplicates ***
- .;
- .I KEEPMED D
- ..S EVENT=$P(NODE,U,15)
- ..I EVENT="" S EVENT=$$NOW^XLFDT
- ..S IDATE=9999999-EVENT
- ..S ARRAY(IDATE,INDEX)=DRUGIDX_"^"_IDX_"^"_ID_"^"_EVENT_"^"_STATUS
- ;
- ; *** Check for empty condition ***
- ;
- ;after you get all the drugs into the array take number requested
- S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
- S COUNTER=0,LINE=0
- S TEMP="Last "_CNT_" drugs from class "_BTIUMED
- D ADD^BTIUMED1(TEMP)
- N I
- S I="" F S I=$O(ARRAY(I)) Q:I=""!(COUNTER>=CNT) D
- .S INDEX="" F S INDEX=$O(ARRAY(I,INDEX)) Q:INDEX="" D
- ..S COUNTER=COUNTER+1
- ..S NODE=^TMP("PS",$J,INDEX,0)
- ..S DATA=$G(ARRAY(I,INDEX))
- ..S STATUS=$P(DATA,U,5)
- ..I STATUS="HOLD" D
- ...S HIEN=+($P(NODE,U))
- ...S REASON=$$GET1^DIQ(52,HIEN,99,"E")
- ...S NODE=NODE_U_REASON
- ..D ADDMED^BTIUMED1(0)
- I COUNTER=0 S LINE=LINE+1 S @TARGET@(LINE,0)="No Meds for this class found"
- Q "~@"_$NA(@TARGET)
- ;
- LISTX K ^TMP("PS",$J)
- Q "~@"_$NA(@TARGET)
- ;
- GETCLASS(BTIUMED) ; Get Drug Class, filter out supplies
- I +DRUGIDX D
- .N TEMPNODE
- .S TEMPNODE=$G(^PSDRUG(DRUGIDX,0))
- .S DRUGCLAS=$P(TEMPNODE,U,2)
- Q
- BTIUMED3 ; SLC/JM - Active/Recent Med Objects Routine ;30-Jul-2010 09:07;MGH
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**1006**;Jun 20, 1997
- +2 ;Object for last class medications
- +3 QUIT
- LIST(DFN,BTIUMED,TARGET,CNT) ; EP
- +1 ;
- +2 ;
- +3 ;
- +4 ;Required Parameters:
- +5 ;
- +6 ; DFN Patient identifier
- +7 ; BTIUMED The drug class to search
- +8 ;
- +9 ; TARGET Where the medication data will be stored
- +10 ; CNT The number to return
- +11 ;
- +12 ;
- +13 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
- +14 NEW INPTYPE,OUTPTYPE,TYPE,MEDTYPE,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST,REASON,REFILLS
- +15 NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,COUNTER,EVENT,HIEN,IEN
- +16 NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,IDX,ID,CLININC
- +17 ;Clean up after external calls...
- NEW %,%H,STOP,LSTFD,ARRAY
- +18 SET (NEXTLINE,TAB,HEADER,UNKNOWNS,CLININC)=0
- SET LLEN=47
- +19 KILL @TARGET,^TMP("PS",$JOB),ARRAY
- +20 ; Is this an inpatient?
- SET ISINP=($GET(^DPT(DFN,.1))'="")
- +21 IF ISINP
- SET INPTYPE=1
- SET OUTPTYPE=2
- +22 IF '$TEST
- SET INPTYPE=2
- SET OUTPTYPE=1
- +23 ;
- +24 ; *** Scan medication data and skip unwanted meds ***
- +25 ;
- +26 SET DAYS=180
- SET ACTVONLY=0
- SET ONELIST=0
- SET DETAILED=1
- +27 IF '$DATA(CNT)=CNT=1
- +28 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
- +29 SET INDEX=0
- +30 FOR
- SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
- IF INDEX'>0
- QUIT
- Begin DoDot:1
- +31 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
- +32 SET CHRONIC=""
- +33 SET STATUS=$PIECE(NODE,U,9)
- +34 SET IDATE=$PIECE(NODE,U,15)
- +35 ;Discard Blank Meds
- SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
- +36 IF $PIECE($PIECE(NODE,U),";",2)["O"
- Begin DoDot:2
- +37 SET RXNO=+($PIECE(NODE,U,1))
- +38 SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)
- +39 IF STATUS="EXPIRED"
- Begin DoDot:3
- +40 NEW X1,X2,X
- +41 IF CHRONIC
- SET X1=DT
- SET X2=-120
- DO C^%DTC
- SET LDATE=X
- +42 IF '$TEST
- SET X1=DT
- SET X2=-14
- DO C^%DTC
- SET LDATE=X
- +43 SET EXDATE=$PIECE($GET(^PSRX(RXNO,2)),U,6)
- +44 IF EXDATE>LDATE
- SET KEEPMED=1
- End DoDot:3
- +45 IF STATUS="DISCONTINUED"
- Begin DoDot:3
- +46 SET X1=DT
- SET X2=-30
- DO C^%DTC
- SET LDATE=X
- +47 SET CANDATE=$PIECE($GET(^PSRX(RXNO,3)),U,5)
- +48 IF CANDATE>LDATE
- SET KEEPMED=1
- End DoDot:3
- End DoDot:2
- +49 IF STATUS="PENDING"
- Begin DoDot:2
- +50 SET IEN=+($PIECE(NODE,U))
- +51 IF IEN>0
- SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)
- +52 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS
- End DoDot:2
- +53 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
- +54 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
- +55 SET KEEPMED=(TYPE'="")
- +56 IF KEEPMED
- Begin DoDot:2
- +57 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
- SET TYPE="IV"
- +58 IF '$TEST
- IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
- SET TYPE="IV"
- +59 IF TYPE="OP"
- SET MEDTYPE=OUTPTYPE
- +60 IF '$TEST
- SET MEDTYPE=INPTYPE
- +61 IF MEDTYPE=INPTYPE
- SET KEEPMED=ISINP
- +62 IF '$TEST
- SET KEEPMED='ISINP
- End DoDot:2
- +63 SET DRUGCLAS=" "
- +64 SET MED=$PIECE(NODE,U,2)
- +65 IF KEEPMED
- Begin DoDot:2
- +66 SET DRUGIDX=$ORDER(^PSDRUG("B",MED,0))
- +67 DO GETCLASS(BTIUMED)
- +68 IF BTIUMED'=DRUGCLAS
- SET KEEPMED=0
- +69 IF KEEPMED
- Begin DoDot:3
- +70 NEW ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
- +71 SET ID=$PIECE(NODE,U)
- +72 SET IDX=+ID
- SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
- +73 SET (DRUGIDX,ORDIDX)=0
- +74 IF ID="R;O"
- SET DRUGIDX=+$PIECE($GET(^PSRX(IDX,0)),U,6)
- +75 IF ID="P;O"
- SET DRUGIDX=+$PIECE($GET(^PS(52.41,IDX,0)),U,9)
- +76 IF ID="P;I"
- Begin DoDot:4
- +77 IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1
- Begin DoDot:5
- +78 SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))
- IF +TMPIDX
- SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)
- End DoDot:5
- End DoDot:4
- +79 IF ID="U;I"
- Begin DoDot:4
- +80 IF $PIECE($GET(^PS(55,DFN,5,IDX,1,0)),U,4)=1
- Begin DoDot:5
- +81 SET TMPIDX=$ORDER(^PS(55,DFN,5,IDX,1,0))
- IF +TMPIDX
- SET DRUGIDX=$PIECE($GET(^PS(55,DFN,5,IDX,1,TMPIDX,0)),U)
- End DoDot:5
- End DoDot:4
- +82 IF ID="V;I"
- Begin DoDot:4
- +83 IF $PIECE($GET(^PS(55,DFN,"IV",IDX,"AD",0)),U,4)=1
- Begin DoDot:5
- +84 SET TMPIDX=$ORDER(^PS(55,DFN,"IV",IDX,"AD",0))
- IF +TMPIDX
- Begin DoDot:6
- +85 SET TMPIDX=$PIECE($GET(^PS(55,DFN,"IV",IDX,"AD",TMPIDX,0)),U)
- +86 IF +TMPIDX
- SET DRUGIDX=$PIECE($GET(^PS(52.6,TMPIDX,0)),U,2)
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +87 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
- +88 ;
- +89 IF KEEPMED
- Begin DoDot:2
- +90 SET EVENT=$PIECE(NODE,U,15)
- +91 IF EVENT=""
- SET EVENT=$$NOW^XLFDT
- +92 SET IDATE=9999999-EVENT
- +93 SET ARRAY(IDATE,INDEX)=DRUGIDX_"^"_IDX_"^"_ID_"^"_EVENT_"^"_STATUS
- End DoDot:2
- End DoDot:1
- +94 ;
- +95 ; *** Check for empty condition ***
- +96 ;
- +97 ;after you get all the drugs into the array take number requested
- +98 SET $PIECE(SPACE60," ",60)=" "
- SET $PIECE(DASH73,"=",73)="="
- +99 SET COUNTER=0
- SET LINE=0
- +100 SET TEMP="Last "_CNT_" drugs from class "_BTIUMED
- +101 DO ADD^BTIUMED1(TEMP)
- +102 NEW I
- +103 SET I=""
- FOR
- SET I=$ORDER(ARRAY(I))
- IF I=""!(COUNTER>=CNT)
- QUIT
- Begin DoDot:1
- +104 SET INDEX=""
- FOR
- SET INDEX=$ORDER(ARRAY(I,INDEX))
- IF INDEX=""
- QUIT
- Begin DoDot:2
- +105 SET COUNTER=COUNTER+1
- +106 SET NODE=^TMP("PS",$JOB,INDEX,0)
- +107 SET DATA=$GET(ARRAY(I,INDEX))
- +108 SET STATUS=$PIECE(DATA,U,5)
- +109 IF STATUS="HOLD"
- Begin DoDot:3
- +110 SET HIEN=+($PIECE(NODE,U))
- +111 SET REASON=$$GET1^DIQ(52,HIEN,99,"E")
- +112 SET NODE=NODE_U_REASON
- End DoDot:3
- +113 DO ADDMED^BTIUMED1(0)
- End DoDot:2
- End DoDot:1
- +114 IF COUNTER=0
- SET LINE=LINE+1
- SET @TARGET@(LINE,0)="No Meds for this class found"
- +115 QUIT "~@"_$NAME(@TARGET)
- +116 ;
- LISTX KILL ^TMP("PS",$JOB)
- +1 QUIT "~@"_$NAME(@TARGET)
- +2 ;
- GETCLASS(BTIUMED) ; Get Drug Class, filter out supplies
- +1 IF +DRUGIDX
- Begin DoDot:1
- +2 NEW TEMPNODE
- +3 SET TEMPNODE=$GET(^PSDRUG(DRUGIDX,0))
- +4 SET DRUGCLAS=$PIECE(TEMPNODE,U,2)
- End DoDot:1
- +5 QUIT
