- BTIUMED6 ; SLC/JM - Active/Recent Med Objects Routine ;16-Sep-2013 15:39;DU
- ;;1.0;TEXT INTEGRATION UTILITIES;**1009,1010,1011,1012**;Jun 20, 1997;Build 45
- ;Patch 1011 changes to use new pharmacy APIS
- Q
- LIST(DFN,TARGET,CLININC) ; EP
- ;
- ; This is the TIU Medication object for medication reconciliation .
- ; Combined report with all meds of the same status combined
- ;
- ;Required Parameters:
- ;
- ; DFN Patient identifier
- ;
- ; TARGET Where the medication data will be stored
- ;
- ;Optional Parameters:
- ;
- ; CLININC 1=Clinical Indication will be included
- ;
- N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
- N INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST
- N LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,ERX
- N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,LSTINDIC,SUPPLIES,AUTO
- N IFN,NVATYPE,NVAMED,NVASTR,TIUXSTAT,CLIN,HIEN,IEN,REASON,REFILLS,COUNTER,EVENT
- N %,%H,STOP,LSTFD ;Clean up after external calls...
- S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47
- K @TARGET,^TMP("PS",$J)
- ; Check for Pharmacy Package and required patches
- I '$$PATCHSOK^TIULMED3 G LISTX ;P213
- I $G(CLININC)'=1 S CLININC=0
- S (EMPTY,HEADER)=1
- S HEADER=1
- S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient?
- S OUTPTYPE=1,INPTYPE=2,NVATYPE=3
- ;
- ; *** Scan medication data and skip unwanted meds ***
- ;
- S DAYS=180,ACTVONLY=0,ONELIST=0,DETAILED=1
- D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
- S INDEX=0,CLASSORT=0,SUPPLIES=0
- F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
- .S CHRONIC="",AUTO=0,ERX=""
- .S NODE=$G(^TMP("PS",$J,INDEX,0))
- .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
- .;Group meds by status
- .S STATUS=$P(NODE,U,9)
- .I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)"
- .S IDATE=$P(NODE,U,15)
- .I $P($P(NODE,U),";",2)["O" D
- ..S RXNO=+($P(NODE,U,1))
- ..S AUTO=$P($G(^PSRX(RXNO,999999921)),U,3)
- .S TYPE=$P($P(NODE,U),";",2)
- .S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
- .S NVAMED=$P($P(NODE,U),";")
- .S NVAMED=$E(NVAMED,$L(NVAMED))
- .I NVAMED="N" D
- ..S IFN=+$P(NODE,U,8)
- ..S STATUS=$$NVSTS^BEHORXFN(IFN,$P(NODE,U,9))
- ..S $P(NODE,U,9)=STATUS
- .I STATUS="EXPIRED" D
- ..I $P($P(NODE,U),";",2)["O" D
- ...S RXNO=+($P(NODE,U,1))
- ...S CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)
- ...N X,X1,X2
- ...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=0
- ..I $P($P(NODE,U),";",2)["I" D
- ...S EXDATE=$P(NODE,U,4)
- ...S X1=DT,X2=-14 D C^%DTC S LDATE=X
- ...I EXDATE<LDATE S KEEPMED=0
- .I STATUS["DISCONTINUED" D
- ..I TYPE="OP" D
- ...I NVAMED="N" S KEEPMED=0 Q
- ...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=0
- ..I TYPE="UD" D
- ...S X1=DT,X2=-2 D C^%DTC S LDATE=X
- ...S CANDATE=$P(NODE,U,4)
- ...I CANDATE<LDATE S KEEPMED=0
- ..I STATUS="DISCONTINUED/EDIT"!(STATUS="DISCONTINUED (EDIT)") S KEEPMED=0
- .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
- ..;I STATUS="HOLD"!(STATUS["TRANSFER") S STATUS="OUTSIDE "_STATUS
- .I TYPE="" S KEEPMED=0
- .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 NVAMED="N" S MEDTYPE=NVATYPE
- .S DRUGCLAS=" "
- .S MED=$P(NODE,U,2)
- .I KEEPMED D
- ..S DRUGIDX=$$IENNAME^TIULMED2(MED)
- ..D GETCLASS
- ..I KEEPMED,+DRUGIDX=0 D ;Find orderable item
- ...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
- ...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
- ...S (DRUGIDX,ORDIDX)=0
- ...K ^TMP($J,"TIULMED")
- ...; IDX is Order #; ID indicates what file. See IA 2400
- ...; R;O MED will always be in Drug File (Unless Drug File entry was
- ...; changed after ordering.
- ...I ID="R;O" D
- ....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820
- ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6))
- ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI"))
- ...I ID="P;O" D
- ....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821
- ....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11))
- ....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8))
- ...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 D
- ......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
- ....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U)
- ....W !,ORDIDX
- ...I ID="U;I" D
- ....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826
- ....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D
- .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0
- .....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
- ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108))
- ...I ID="V;I" D
- ....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826
- ....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
- ....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130))
- ....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D
- .....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D
- ......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01))
- ......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662
- ...S DRUGCLAS=""
- ...D GETCLASS
- ...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D
- ....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES
- ....N LIST S LIST="TIULMED" K ^TMP($J,LIST)
- ....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662
- ....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE)
- .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
- .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
- .....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS=""
- .....I 'CDONE D
- ......I DRUGCLAS="" S DRUGCLAS=TMPCLASS
- ......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS=""
- .....I 'SDONE D
- ......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S"))
- ......I 'ISSUPPLY S SDONE=1
- ....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0
- ..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" "
- ..I AUTO=1 D
- ...S ERX=$P($G(^PSRX(RXNO,999999921)),U,4)
- ...I +ERX S ERX=ERX_";"_RXNO
- ...S $P(^TMP("PS",$J,INDEX,0),U,9)=STATUS_" (X)"
- .;
- .; *** Save wanted meds in "B" temp xref, removing duplicates ***
- .;
- .I KEEPMED D
- ..D ADDMED^BTIUMED1(1,1) ; Get XSTR to check for duplicates
- ..S IDATE=$P(NODE,U,15)
- ..I $P($P(NODE,U),";")["N" S IDATE=$$DT^XLFDT
- ..I $P(NODE,U,9)="PENDING"!($P(NODE,U,9)="HOLD") S IDATE=$$DT^XLFDT
- ..S OK='$D(@TARGET@("B",MED,XSTR))
- ..I 'OK,(IDATE>+@TARGET@("B",MED,XSTR)) S OK=1
- ..I 'OK,$P(@TARGET@("B",MED,XSTR),U,4)'=STATUS S OK=1
- ..I OK D
- ...S @TARGET@("B",MED,IDATE,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATUS_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_ERX
- ...S EMPTY=0
- ...I DRUGCLAS=" " S UNKNOWNS=1
- ;
- ; *** Check for empty condition ***
- ;
- I EMPTY D G LISTX
- .D ADD^BTIUMED1("No Medications Found")
- .D ADD^BTIUMED1(" ")
- ;
- ; *** Sort Meds in "C" temp xref - sort by Status,MedType,
- ; Med Name, and reverse issue date, followed by a counter
- ; to avoid erasing meds issued on the same day
- ;
- S MED="",CNT=1000000
- F S MED=$O(@TARGET@("B",MED)) Q:MED="" D
- .S IDATE=""
- .F S IDATE=$O(@TARGET@("B",MED,IDATE)) Q:IDATE="" D
- ..S XSTR=""
- ..F S XSTR=$O(@TARGET@("B",MED,IDATE,XSTR)) Q:XSTR="" D
- ...S NODE=@TARGET@("B",MED,IDATE,XSTR)
- ...S DATA=MED_U_$P(NODE,U,3)_U_$P(NODE,U,5),CNT=CNT+1
- ...S STATUS=$P(NODE,U,4)
- ...S @TARGET@("C",STATUS,DATA,(9999999-$P(NODE,U))_CNT)=$P(NODE,U,2)_U_$P(NODE,U,5)_U_$P(NODE,U,7)_U_$P(NODE,U,8)_U_$P(NODE,U,3)
- K @TARGET@("B")
- ;
- ; Read sorted data and save final version to TARGET
- ;
- S (DATA,LASTCLAS,LSTINDIC)="",(LASTMEDT,LASTSTS,COUNT,TOTAL)=0
- S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
- D WARNING^BTIUMED1
- S STATUS="",MEDTYPE=""
- F S STATUS=$O(@TARGET@("C",STATUS)) Q:STATUS="" D
- .F S DATA=$O(@TARGET@("C",STATUS,DATA)) Q:DATA="" D
- ..S DRUGCLAS=$P(DATA,U,2),MED=$P(DATA,U,3),CNT=""
- ..F S CNT=$O(@TARGET@("C",STATUS,DATA,CNT)) Q:CNT="" D
- ...S INDEX=@TARGET@("C",STATUS,DATA,CNT)
- ...S TYPE=$P(INDEX,U,2),CHRONIC=$P(INDEX,U,3),MEDTYPE=$P(INDEX,U,5),ERX=$P(INDEX,U,4),INDEX=+INDEX
- ...S NODE=^TMP("PS",$J,INDEX,0)
- ...;If hold meds, find the reason and add it to the node data
- ...I STATUS="HOLD" D
- ....S HIEN=+($P(NODE,U))
- ....S REASON=$$GET1^DIQ(52,HIEN,99,"E")
- ....S NODE=NODE_U_REASON
- ...I CLININC=1 D
- ....S HIEN=+($P(NODE,U))
- ....S CLIN=$$GET1^DIQ(52,HIEN,9999999.21,"E")
- ....S $P(NODE,U,2)=$P(NODE,U,2)_" "_CLIN
- ...E S $P(NODE,U,2)=" "_$P(NODE,U,2)
- ...I ERX'="" S $P(NODE,U,31)=ERX
- ...I (STATUS'=LASTSTS) D ; Create Header
- ....I 'HEADER Q
- ....S LASTSTS=STATUS,TAB=0
- ....I COUNT>0 D ADD^BTIUMED1(" ")
- ....S COUNT=0
- ....D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
- ....S TEMP=STATUS_" "
- ....S TEMP=STATUS_" Medications"
- ....S TEMP=$E(TEMP_SPACE60,1,47)
- ....S TEMP=TEMP_"Refills"
- ....S TEMP=$E(TEMP_SPACE60,1,60)
- ....I MEDTYPE=INPTYPE S TEMP=TEMP_"Stop/Exp Dte"
- ....D ADD^BTIUMED1(TEMP),ADD^BTIUMED1(DASH73)
- ...S COUNT=COUNT+1,TOTAL=TOTAL+1
- ...D ADDMED^BTIUMED1(0,1)
- I COUNT'=TOTAL D
- .S TAB=0
- .D ADD^BTIUMED1(" ")
- .D ADD^BTIUMED1("(X)behind status of medication depicts that the medication was sent to an external pharmacy")
- K @TARGET@("C")
- LISTX K ^TMP("PS",$J)
- Q "~@"_$NA(@TARGET)
- ;
- GETCLASS ; Get Drug Class, filter out supplies
- D GETCLASS^TIULMED3
- Q
- BTIUMED6 ; SLC/JM - Active/Recent Med Objects Routine ;16-Sep-2013 15:39;DU
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**1009,1010,1011,1012**;Jun 20, 1997;Build 45
- +2 ;Patch 1011 changes to use new pharmacy APIS
- +3 QUIT
- LIST(DFN,TARGET,CLININC) ; EP
- +1 ;
- +2 ; This is the TIU Medication object for medication reconciliation .
- +3 ; Combined report with all meds of the same status combined
- +4 ;
- +5 ;Required Parameters:
- +6 ;
- +7 ; DFN Patient identifier
- +8 ;
- +9 ; TARGET Where the medication data will be stored
- +10 ;
- +11 ;Optional Parameters:
- +12 ;
- +13 ; CLININC 1=Clinical Indication will be included
- +14 ;
- +15 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
- +16 NEW INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST
- +17 NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,ERX
- +18 NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,LSTINDIC,SUPPLIES,AUTO
- +19 NEW IFN,NVATYPE,NVAMED,NVASTR,TIUXSTAT,CLIN,HIEN,IEN,REASON,REFILLS,COUNTER,EVENT
- +20 ;Clean up after external calls...
- NEW %,%H,STOP,LSTFD
- +21 SET (NEXTLINE,TAB,HEADER,UNKNOWNS)=0
- SET LLEN=47
- +22 KILL @TARGET,^TMP("PS",$JOB)
- +23 ; Check for Pharmacy Package and required patches
- +24 ;P213
- IF '$$PATCHSOK^TIULMED3
- GOTO LISTX
- +25 IF $GET(CLININC)'=1
- SET CLININC=0
- +26 SET (EMPTY,HEADER)=1
- +27 SET HEADER=1
- +28 ; Is this an inpatient?
- SET ISINP=($GET(^DPT(DFN,.1))'="")
- +29 SET OUTPTYPE=1
- SET INPTYPE=2
- SET NVATYPE=3
- +30 ;
- +31 ; *** Scan medication data and skip unwanted meds ***
- +32 ;
- +33 SET DAYS=180
- SET ACTVONLY=0
- SET ONELIST=0
- SET DETAILED=1
- +34 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
- +35 SET INDEX=0
- SET CLASSORT=0
- SET SUPPLIES=0
- +36 FOR
- SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
- IF INDEX'>0
- QUIT
- Begin DoDot:1
- +37 SET CHRONIC=""
- SET AUTO=0
- SET ERX=""
- +38 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
- +39 ;Discard Blank Meds
- SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
- +40 ;Group meds by status
- +41 SET STATUS=$PIECE(NODE,U,9)
- +42 IF STATUS="ACTIVE/SUSP"
- SET STATUS="ACTIVE (S)"
- +43 SET IDATE=$PIECE(NODE,U,15)
- +44 IF $PIECE($PIECE(NODE,U),";",2)["O"
- Begin DoDot:2
- +45 SET RXNO=+($PIECE(NODE,U,1))
- +46 SET AUTO=$PIECE($GET(^PSRX(RXNO,999999921)),U,3)
- End DoDot:2
- +47 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
- +48 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
- +49 SET NVAMED=$PIECE($PIECE(NODE,U),";")
- +50 SET NVAMED=$EXTRACT(NVAMED,$LENGTH(NVAMED))
- +51 IF NVAMED="N"
- Begin DoDot:2
- +52 SET IFN=+$PIECE(NODE,U,8)
- +53 SET STATUS=$$NVSTS^BEHORXFN(IFN,$PIECE(NODE,U,9))
- +54 SET $PIECE(NODE,U,9)=STATUS
- End DoDot:2
- +55 IF STATUS="EXPIRED"
- Begin DoDot:2
- +56 IF $PIECE($PIECE(NODE,U),";",2)["O"
- Begin DoDot:3
- +57 SET RXNO=+($PIECE(NODE,U,1))
- +58 SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)
- +59 NEW X,X1,X2
- +60 IF CHRONIC
- SET X1=DT
- SET X2=-120
- DO C^%DTC
- SET LDATE=X
- +61 IF '$TEST
- SET X1=DT
- SET X2=-14
- DO C^%DTC
- SET LDATE=X
- +62 SET EXDATE=$PIECE($GET(^PSRX(RXNO,2)),U,6)
- +63 IF EXDATE<LDATE
- SET KEEPMED=0
- End DoDot:3
- +64 IF $PIECE($PIECE(NODE,U),";",2)["I"
- Begin DoDot:3
- +65 SET EXDATE=$PIECE(NODE,U,4)
- +66 SET X1=DT
- SET X2=-14
- DO C^%DTC
- SET LDATE=X
- +67 IF EXDATE<LDATE
- SET KEEPMED=0
- End DoDot:3
- End DoDot:2
- +68 IF STATUS["DISCONTINUED"
- Begin DoDot:2
- +69 IF TYPE="OP"
- Begin DoDot:3
- +70 IF NVAMED="N"
- SET KEEPMED=0
- QUIT
- +71 SET X1=DT
- SET X2=-30
- DO C^%DTC
- SET LDATE=X
- +72 SET CANDATE=$PIECE($GET(^PSRX(RXNO,3)),U,5)
- +73 IF CANDATE<LDATE
- SET KEEPMED=0
- End DoDot:3
- +74 IF TYPE="UD"
- Begin DoDot:3
- +75 SET X1=DT
- SET X2=-2
- DO C^%DTC
- SET LDATE=X
- +76 SET CANDATE=$PIECE(NODE,U,4)
- +77 IF CANDATE<LDATE
- SET KEEPMED=0
- End DoDot:3
- +78 IF STATUS="DISCONTINUED/EDIT"!(STATUS="DISCONTINUED (EDIT)")
- SET KEEPMED=0
- End DoDot:2
- +79 IF STATUS="PENDING"
- Begin DoDot:2
- +80 SET IEN=+($PIECE(NODE,U))
- +81 IF IEN>0
- SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)
- +82 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS
- +83 ;I STATUS="HOLD"!(STATUS["TRANSFER") S STATUS="OUTSIDE "_STATUS
- End DoDot:2
- +84 IF TYPE=""
- SET KEEPMED=0
- +85 IF KEEPMED
- Begin DoDot:2
- +86 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
- SET TYPE="IV"
- +87 IF '$TEST
- IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
- SET TYPE="IV"
- +88 IF TYPE="OP"
- SET MEDTYPE=OUTPTYPE
- +89 IF '$TEST
- SET MEDTYPE=INPTYPE
- +90 IF NVAMED="N"
- SET MEDTYPE=NVATYPE
- End DoDot:2
- +91 SET DRUGCLAS=" "
- +92 SET MED=$PIECE(NODE,U,2)
- +93 IF KEEPMED
- Begin DoDot:2
- +94 SET DRUGIDX=$$IENNAME^TIULMED2(MED)
- +95 DO GETCLASS
- +96 ;Find orderable item
- IF KEEPMED
- IF +DRUGIDX=0
- Begin DoDot:3
- +97 NEW IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
- +98 SET ID=$PIECE(NODE,U)
- SET IDX=+ID
- SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
- +99 SET (DRUGIDX,ORDIDX)=0
- +100 KILL ^TMP($JOB,"TIULMED")
- +101 ; IDX is Order #; ID indicates what file. See IA 2400
- +102 ; R;O MED will always be in Drug File (Unless Drug File entry was
- +103 ; changed after ordering.
- +104 IF ID="R;O"
- Begin DoDot:4
- +105 ; IA 4820
- DO RX^PSO52API(DFN,"TIULMED",IDX,"","0,O")
- +106 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,6))
- +107 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,"OI"))
- End DoDot:4
- +108 IF ID="P;O"
- Begin DoDot:4
- +109 ; IA 4821
- DO PEN^PSO5241(DFN,"TIULMED",IDX)
- +110 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,11))
- +111 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,8))
- End DoDot:4
- +112 IF ID="P;I"
- Begin DoDot:4
- +113 IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1
- Begin DoDot:5
- +114 SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))
- IF +TMPIDX
- Begin DoDot:6
- +115 SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)
- End DoDot:6
- End DoDot:5
- +116 SET ORDIDX=+$PIECE($GET(^PS(53.1,IDX,.2)),U)
- +117 WRITE !,ORDIDX
- End DoDot:4
- +118 IF ID="U;I"
- Begin DoDot:4
- +119 ; IA 4826
- DO PSS431^PSS55(DFN,IDX,"","","TIULMED")
- +120 IF +$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))=1
- Begin DoDot:5
- +121 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))
- IF TMPIDX'>0
- QUIT
- +122 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
- End DoDot:5
- +123 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,108))
- End DoDot:4
- +124 IF ID="V;I"
- Begin DoDot:4
- +125 ; IA 4826
- DO PSS436^PSS55(DFN,IDX,"TIULMED")
- +126 ; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
- +127 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,130))
- +128 IF ^TMP($JOB,"TIULMED",IDX,"ADD",0)=1
- Begin DoDot:5
- +129 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"ADD",0))
- IF +TMPIDX
- Begin DoDot:6
- +130 SET TMPIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"ADD",TMPIDX,.01))
- +131 ; IA 4662
- IF +TMPIDX
- SET DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX)
- End DoDot:6
- End DoDot:5
- End DoDot:4
- +132 SET DRUGCLAS=""
- +133 DO GETCLASS
- +134 IF KEEPMED
- IF +DRUGIDX=0
- IF +ORDIDX
- IF DRUGCLAS=""
- Begin DoDot:4
- +135 SET IDX=0
- SET ISSUPPLY=2
- SET CDONE='CLASSORT
- SET SDONE=+SUPPLIES
- +136 NEW LIST
- SET LIST="TIULMED"
- KILL ^TMP($JOB,LIST)
- +137 ; IA 4662
- DO DRGIEN^PSS50P7(ORDIDX,"",LIST)
- +138 FOR
- SET IDX=$ORDER(^TMP($JOB,LIST,IDX))
- IF 'IDX
- QUIT
- Begin DoDot:5
- +139 SET TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
- +140 SET TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
- +141 IF 'CDONE
- IF TMPCLASS=""
- SET CDONE=1
- SET DRUGCLAS=""
- +142 IF 'CDONE
- Begin DoDot:6
- +143 IF DRUGCLAS=""
- SET DRUGCLAS=TMPCLASS
- +144 IF '$TEST
- IF DRUGCLAS'=TMPCLASS
- SET CDONE=1
- SET DRUGCLAS=""
- End DoDot:6
- +145 IF 'SDONE
- Begin DoDot:6
- +146 SET ISSUPPLY=(($EXTRACT(TMPCLASS,1,2)="XA")&($PIECE(TMPNODE,U,3)["S"))
- +147 IF 'ISSUPPLY
- SET SDONE=1
- End DoDot:6
- End DoDot:5
- IF (CDONE&SDONE)
- QUIT
- +148 IF 'SUPPLIES
- IF (ISSUPPLY=1)
- SET KEEPMED=0
- End DoDot:4
- End DoDot:3
- +149 IF (DRUGCLAS="")!('CLASSORT)
- SET DRUGCLAS=" "
- +150 IF AUTO=1
- Begin DoDot:3
- +151 SET ERX=$PIECE($GET(^PSRX(RXNO,999999921)),U,4)
- +152 IF +ERX
- SET ERX=ERX_";"_RXNO
- +153 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,9)=STATUS_" (X)"
- End DoDot:3
- End DoDot:2
- +154 ;
- +155 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
- +156 ;
- +157 IF KEEPMED
- Begin DoDot:2
- +158 ; Get XSTR to check for duplicates
- DO ADDMED^BTIUMED1(1,1)
- +159 SET IDATE=$PIECE(NODE,U,15)
- +160 IF $PIECE($PIECE(NODE,U),";")["N"
- SET IDATE=$$DT^XLFDT
- +161 IF $PIECE(NODE,U,9)="PENDING"!($PIECE(NODE,U,9)="HOLD")
- SET IDATE=$$DT^XLFDT
- +162 SET OK='$DATA(@TARGET@("B",MED,XSTR))
- +163 IF 'OK
- IF (IDATE>+@TARGET@("B",MED,XSTR))
- SET OK=1
- +164 IF 'OK
- IF $PIECE(@TARGET@("B",MED,XSTR),U,4)'=STATUS
- SET OK=1
- +165 IF OK
- Begin DoDot:3
- +166 SET @TARGET@("B",MED,IDATE,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATUS_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_ERX
- +167 SET EMPTY=0
- +168 IF DRUGCLAS=" "
- SET UNKNOWNS=1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +169 ;
- +170 ; *** Check for empty condition ***
- +171 ;
- +172 IF EMPTY
- Begin DoDot:1
- +173 DO ADD^BTIUMED1("No Medications Found")
- +174 DO ADD^BTIUMED1(" ")
- End DoDot:1
- GOTO LISTX
- +175 ;
- +176 ; *** Sort Meds in "C" temp xref - sort by Status,MedType,
- +177 ; Med Name, and reverse issue date, followed by a counter
- +178 ; to avoid erasing meds issued on the same day
- +179 ;
- +180 SET MED=""
- SET CNT=1000000
- +181 FOR
- SET MED=$ORDER(@TARGET@("B",MED))
- IF MED=""
- QUIT
- Begin DoDot:1
- +182 SET IDATE=""
- +183 FOR
- SET IDATE=$ORDER(@TARGET@("B",MED,IDATE))
- IF IDATE=""
- QUIT
- Begin DoDot:2
- +184 SET XSTR=""
- +185 FOR
- SET XSTR=$ORDER(@TARGET@("B",MED,IDATE,XSTR))
- IF XSTR=""
- QUIT
- Begin DoDot:3
- +186 SET NODE=@TARGET@("B",MED,IDATE,XSTR)
- +187 SET DATA=MED_U_$PIECE(NODE,U,3)_U_$PIECE(NODE,U,5)
- SET CNT=CNT+1
- +188 SET STATUS=$PIECE(NODE,U,4)
- +189 SET @TARGET@("C",STATUS,DATA,(9999999-$PIECE(NODE,U))_CNT)=$PIECE(NODE,U,2)_U_$PIECE(NODE,U,5)_U_$PIECE(NODE,U,7)_U_$PIECE(NODE,U,8)_U_$PIECE(NODE,U,3)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +190 KILL @TARGET@("B")
- +191 ;
- +192 ; Read sorted data and save final version to TARGET
- +193 ;
- +194 SET (DATA,LASTCLAS,LSTINDIC)=""
- SET (LASTMEDT,LASTSTS,COUNT,TOTAL)=0
- +195 SET $PIECE(SPACE60," ",60)=" "
- SET $PIECE(DASH73,"=",73)="="
- +196 DO WARNING^BTIUMED1
- +197 SET STATUS=""
- SET MEDTYPE=""
- +198 FOR
- SET STATUS=$ORDER(@TARGET@("C",STATUS))
- IF STATUS=""
- QUIT
- Begin DoDot:1
- +199 FOR
- SET DATA=$ORDER(@TARGET@("C",STATUS,DATA))
- IF DATA=""
- QUIT
- Begin DoDot:2
- +200 SET DRUGCLAS=$PIECE(DATA,U,2)
- SET MED=$PIECE(DATA,U,3)
- SET CNT=""
- +201 FOR
- SET CNT=$ORDER(@TARGET@("C",STATUS,DATA,CNT))
- IF CNT=""
- QUIT
- Begin DoDot:3
- +202 SET INDEX=@TARGET@("C",STATUS,DATA,CNT)
- +203 SET TYPE=$PIECE(INDEX,U,2)
- SET CHRONIC=$PIECE(INDEX,U,3)
- SET MEDTYPE=$PIECE(INDEX,U,5)
- SET ERX=$PIECE(INDEX,U,4)
- SET INDEX=+INDEX
- +204 SET NODE=^TMP("PS",$JOB,INDEX,0)
- +205 ;If hold meds, find the reason and add it to the node data
- +206 IF STATUS="HOLD"
- Begin DoDot:4
- +207 SET HIEN=+($PIECE(NODE,U))
- +208 SET REASON=$$GET1^DIQ(52,HIEN,99,"E")
- +209 SET NODE=NODE_U_REASON
- End DoDot:4
- +210 IF CLININC=1
- Begin DoDot:4
- +211 SET HIEN=+($PIECE(NODE,U))
- +212 SET CLIN=$$GET1^DIQ(52,HIEN,9999999.21,"E")
- +213 SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" "_CLIN
- End DoDot:4
- +214 IF '$TEST
- SET $PIECE(NODE,U,2)=" "_$PIECE(NODE,U,2)
- +215 IF ERX'=""
- SET $PIECE(NODE,U,31)=ERX
- +216 ; Create Header
- IF (STATUS'=LASTSTS)
- Begin DoDot:4
- +217 IF 'HEADER
- QUIT
- +218 SET LASTSTS=STATUS
- SET TAB=0
- +219 IF COUNT>0
- DO ADD^BTIUMED1(" ")
- +220 SET COUNT=0
- +221 DO ADD^BTIUMED1($EXTRACT($EXTRACT(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
- +222 SET TEMP=STATUS_" "
- +223 SET TEMP=STATUS_" Medications"
- +224 SET TEMP=$EXTRACT(TEMP_SPACE60,1,47)
- +225 SET TEMP=TEMP_"Refills"
- +226 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)
- +227 IF MEDTYPE=INPTYPE
- SET TEMP=TEMP_"Stop/Exp Dte"
- +228 DO ADD^BTIUMED1(TEMP)
- DO ADD^BTIUMED1(DASH73)
- End DoDot:4
- +229 SET COUNT=COUNT+1
- SET TOTAL=TOTAL+1
- +230 DO ADDMED^BTIUMED1(0,1)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +231 IF COUNT'=TOTAL
- Begin DoDot:1
- +232 SET TAB=0
- +233 DO ADD^BTIUMED1(" ")
- +234 DO ADD^BTIUMED1("(X)behind status of medication depicts that the medication was sent to an external pharmacy")
- End DoDot:1
- +235 KILL @TARGET@("C")
- LISTX KILL ^TMP("PS",$JOB)
- +1 QUIT "~@"_$NAME(@TARGET)
- +2 ;
- GETCLASS ; Get Drug Class, filter out supplies
- +1 DO GETCLASS^TIULMED3
- +2 QUIT