BTIUMED4.m

BTIUMED4 ; SLC/JM - Active/Recent Med Objects Routine ;19-Jul-2016 08:11;du

 ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1007,1010,1011,1016**;Jun 20, 1997;Build 10

 ;Drugs sorted by clincial indication

 ;Patch 1011 changed to use new pharmacy APIs

 Q

LIST(DFN,TARGET) ; EP

 ;

 ;

 ;

 ;Required Parameters:

 ;

 ;  DFN       Patient identifier

 ;

 ;  TARGET    Where the medication data will be stored

 ;

 ;Optional Parameters:

 ;

 ;

 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,AUTO

 N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,CLININC,ERX

 N %,%H,STOP,LSTFD,HIEN,IEN,REASON,REFILLS,X,X1,X2,SUPPLIES

 S CLININC=0

 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

 S (EMPTY,HEADER)=1

 S HEADER=1

 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=$$GET^XPAR("ALL","BTIU EXPIRED MEDS",1,"E")

 S:$G(DAYS)<1 DAYS=180

 S 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 NODE=$G(^TMP("PS",$J,INDEX,0))

 .S CHRONIC="",ERX="",AUTO=0

 .S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds

 .;Get the 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 CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)

 ..I STATUS="EXPIRED" D

 ...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 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=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 $P($P(NODE,U),";")["N" S STATUS="OUTSIDE"

 .S TYPE=$P($P(NODE,U),";",2)

 .S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")

 .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 MEDTYPE=INPTYPE S KEEPMED=ISINP

 ..E  S KEEPMED='ISINP

 .S DRUGCLAS=" "

 .S MED=$P(NODE,U,2)

 .I KEEPMED D

 ..S DRUGIDX=$$IENNAME^TIULMED2(MED)

 ..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")

 ...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)

 ...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

 ...I KEEPMED,+DRUGIDX=0,+ORDIDX D

 ....S IDX=0,ISSUPPLY=2,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:(SDONE)

 .....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX)

 .....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)

 .....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 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) ; Get XSTR to check for duplicates

 ..S IDATE=$P(NODE,U,15)

 ..S OK='$D(@TARGET@("B",MED,XSTR))

 ..I 'OK,(IDATE>@TARGET@("B",MED,XSTR)) S OK=1

 ..;Get the clinical indication

 ..;Patch 1016 changes

 ..S HIEN=$P(NODE,U)

 ..I HIEN["R" D

 ...S HIEN=+HIEN

 ...S INDIC=$$GET1^DIQ(52,HIEN,9999999.21,"E")

 ...I INDIC="" S INDIC="Clinical Indication Unknown"

 ..I HIEN["P" S INDIC="Clinical Indication Unknown"

 ..I HIEN["N" S INDIC="Clinical Indication Unknown"

 ..S $P(NODE,U,2)=$P(NODE,U,2)_" "_INDIC

 ..I OK D

 ...S @TARGET@("B",MED,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATUS_U_TYPE_U_CHRONIC_U_INDIC_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 XSTR=""

 .F  S XSTR=$O(@TARGET@("B",MED,XSTR)) Q:XSTR=""  D

 ..S NODE=@TARGET@("B",MED,XSTR)

 ..S DATA=MED_U_$P(NODE,U,3)_U_$P(NODE,U,5),CNT=CNT+1

 ..S STATUS=$P(NODE,U,4)

 ..S INDIC=$P(NODE,U,7)

 ..S @TARGET@("C",INDIC,STATUS,DATA,(9999999-$P(NODE,U))_CNT)=$P(NODE,U,2)_U_$P(NODE,U,5)_U_$P(NODE,U,6)_U_$P(NODE,U,8)

 K @TARGET@("B")

 ;

 ; Read sorted data and save final version to TARGET

 ;

 S (DATA,LSTINDIC)="",(LASTMEDT,COUNT,TOTAL)=0

 S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="

 D WARNING^BTIUMED1

 S (STATUS,INDIC,DATA)=""

 F  S INDIC=$O(@TARGET@("C",INDIC)) Q:INDIC=""  D

 .F  S STATUS=$O(@TARGET@("C",INDIC,STATUS)) Q:STATUS=""  D

 ..F  S DATA=$O(@TARGET@("C",INDIC,STATUS,DATA)) Q:DATA=""  D

 ...S MEDTYPE=$P(DATA,U,2)

 ...S DRUGCLAS=$P(DATA,U,2),MED=$P(DATA,U,3),CNT=""

 ...F  S CNT=$O(@TARGET@("C",INDIC,STATUS,DATA,CNT)) Q:CNT=""  D

 ....S INDEX=@TARGET@("C",INDIC,STATUS,DATA,CNT)

 ....S TYPE=$P(INDEX,U,2),CHRONIC=$P(INDEX,U,3),ERX=$P(INDEX,U,4),INDEX=+INDEX

 ....S NODE=^TMP("PS",$J,INDEX,0)

 ....;IHS/MSC/MGH  Patch 1010

 ....I STATUS="OUTSIDE" S $P(NODE,U,9)=STATUS

 ....;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 ERX'="" S $P(NODE,U,31)=ERX

 ....;I (MEDTYPE'=LASTMEDT)!(STATUS'=LASTSTS)!(INDIC'=LSTINDIC) D  ; Create Header

 ....I (INDIC'=LSTINDIC) D  ; Create Header

 .....I 'HEADER Q

 .....S LSTINDIC=INDIC,TAB=0

 .....I COUNT>0 D ADD^BTIUMED1(" ")

 .....S COUNT=0

 .....I MEDTYPE=OUTPTYPE D  I 1

 ......;D ADD^BTIUMED1(SPACE60_"Issue Date")

 ......;D ADD^BTIUMED1(SPACE60)

 ......;I STATUS="OUTSIDE" D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60))

 ......D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")

 .....S TEMP=INDIC_" "

 .....;S TEMP=$S(STATIDX=1:"Active",STATIDX=2:"Pending",1:"Inactive")_" "

 .....;S TEMP=TEMP_$S(MEDTYPE=INPTYPE:"Inpatient",1:"Outpatient")

 .....;S TEMP="     "_TEMP_" Medications"

 .....S TEMP=$E(TEMP_SPACE60,1,47)

 .....I MEDTYPE=INPTYPE S TEMP=TEMP_"Status"

 .....E  I STATUS="OUTSIDE" S TEMP=TEMP

 .....E  S TEMP=TEMP_"Refills"

 .....S TEMP=$E(TEMP_SPACE60,1,60)

 .....I MEDTYPE=INPTYPE S TEMP=TEMP_"Stop Date"

 .....E  I STATUS'="OUTSIDE" S TEMP=TEMP_"Expiration"

 .....D ADD^BTIUMED1(TEMP),ADD^BTIUMED1(DASH73)

 ....S COUNT=COUNT+1,TOTAL=TOTAL+1

 ....D ADDMED^BTIUMED1(0)

 I COUNT'=TOTAL D

 .S TAB=0

 .D ADD^BTIUMED1(" ")

 .D ADD^BTIUMED1(TOTAL_" Total Medications")

 K @TARGET@("C")

LISTX K ^TMP("PS",$J)

 Q "~@"_$NA(@TARGET)

 ;

GETCLASS ; Get Drug Class, filter out supplies

 D GETCLASS^TIULMED3

 Q

BTIUMED4  ; SLC/JM - Active/Recent Med Objects Routine ;19-Jul-2016 08:11;du

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1007,1010,1011,1016**;Jun 20, 1997;Build 10

 +2       ;Drugs sorted by clincial indication

 +3       ;Patch 1011 changed to use new pharmacy APIs

 +4        QUIT 

LIST(DFN,TARGET) ; EP

 +1       ;

 +2       ;

 +3       ;

 +4       ;Required Parameters:

 +5       ;

 +6       ;  DFN       Patient identifier

 +7       ;

 +8       ;  TARGET    Where the medication data will be stored

 +9       ;

 +10      ;Optional Parameters:

 +11      ;

 +12      ;

 +13       NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED

 +14       NEW INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST

 +15       NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,AUTO

 +16       NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,CLININC,ERX

 +17       NEW %,%H,STOP,LSTFD,HIEN,IEN,REASON,REFILLS,X,X1,X2,SUPPLIES

 +18       SET CLININC=0

 +19       SET (NEXTLINE,TAB,HEADER,UNKNOWNS)=0

           SET LLEN=47

 +20       KILL @TARGET,^TMP("PS",$JOB)

 +21      ; Check for Pharmacy Package and required patches

 +22      ;P213

           IF '$$PATCHSOK^TIULMED3

               GOTO LISTX

 +23       SET (EMPTY,HEADER)=1

 +24       SET HEADER=1

 +25      ; Is this an inpatient?

           SET ISINP=($GET(^DPT(DFN,.1))'="")

 +26       IF ISINP

               SET INPTYPE=1

               SET OUTPTYPE=2

 +27      IF '$TEST

               SET INPTYPE=2

               SET OUTPTYPE=1

 +28      ;

 +29      ; *** Scan medication data and skip unwanted meds ***

 +30      ;

 +31       SET DAYS=$$GET^XPAR("ALL","BTIU EXPIRED MEDS",1,"E")

 +32       IF $GET(DAYS)<1

               SET DAYS=180

 +33       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 NODE=$GET(^TMP("PS",$JOB,INDEX,0))

 +38               SET CHRONIC=""

                   SET ERX=""

                   SET AUTO=0

 +39      ;Discard Blank Meds

                   SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)

 +40      ;Get the 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)

 +47                       SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)

 +48                       IF STATUS="EXPIRED"

                               Begin DoDot:3

 +49                               IF CHRONIC

                                       SET X1=DT

                                       SET X2=-120

                                       DO C^%DTC

                                       SET LDATE=X

 +50                              IF '$TEST

                                       SET X1=DT

                                       SET X2=-14

                                       DO C^%DTC

                                       SET LDATE=X

 +51                               SET EXDATE=$PIECE($GET(^PSRX(RXNO,2)),U,6)

 +52                               IF EXDATE<LDATE

                                       SET KEEPMED=0

                               End DoDot:3

                       End DoDot:2

 +53               IF STATUS["DISCONTINUED"

                       Begin DoDot:2

 +54                       SET X1=DT

                           SET X2=-30

                           DO C^%DTC

                           SET LDATE=X

 +55                       SET CANDATE=$PIECE($GET(^PSRX(RXNO,3)),U,5)

 +56                       IF CANDATE<LDATE

                               SET KEEPMED=0

                       End DoDot:2

 +57               IF STATUS="PENDING"

                       Begin DoDot:2

 +58                       SET IEN=+($PIECE(NODE,U))

 +59                       IF IEN>0

                               SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)

 +60                       SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS

                       End DoDot:2

 +61               IF $PIECE($PIECE(NODE,U),";")["N"

                       SET STATUS="OUTSIDE"

 +62               SET TYPE=$PIECE($PIECE(NODE,U),";",2)

 +63               SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")

 +64               IF TYPE=""

                       SET KEEPMED=0

 +65               IF KEEPMED

                       Begin DoDot:2

 +66                       IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0

                               SET TYPE="IV"

 +67                      IF '$TEST

                               IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0

                                   SET TYPE="IV"

 +68                       IF TYPE="OP"

                               SET MEDTYPE=OUTPTYPE

 +69                      IF '$TEST

                               SET MEDTYPE=INPTYPE

 +70                       IF MEDTYPE=INPTYPE

                               SET KEEPMED=ISINP

 +71                      IF '$TEST

                               SET KEEPMED='ISINP

                       End DoDot:2

 +72               SET DRUGCLAS=" "

 +73               SET MED=$PIECE(NODE,U,2)

 +74               IF KEEPMED

                       Begin DoDot:2

 +75                       SET DRUGIDX=$$IENNAME^TIULMED2(MED)

 +76      ;Find orderable item

                           IF KEEPMED

                               IF +DRUGIDX=0

                                   Begin DoDot:3

 +77                                   NEW IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY

 +78                                   SET ID=$PIECE(NODE,U)

                                       SET IDX=+ID

                                       SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))

 +79                                   SET (DRUGIDX,ORDIDX)=0

 +80                                   KILL ^TMP($JOB,"TIULMED")

 +81                                   IF ID="R;O"

                                           Begin DoDot:4

 +82      ; IA 4820

                                               DO RX^PSO52API(DFN,"TIULMED",IDX,"","0,O")

 +83                                           SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,6))

 +84                                           SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,"OI"))

                                           End DoDot:4

 +85                                   IF ID="P;O"

                                           Begin DoDot:4

 +86      ; IA 4821

                                               DO PEN^PSO5241(DFN,"TIULMED",IDX)

 +87                                           SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,11))

 +88                                           SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,8))

                                           End DoDot:4

 +89                                   IF ID="P;I"

                                           Begin DoDot:4

 +90                                           IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1

                                                   Begin DoDot:5

 +91                                                   SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))

                                                       IF +TMPIDX

                                                           Begin DoDot:6

 +92                                                           SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)

                                                           End DoDot:6

                                                   End DoDot:5

 +93                                           SET ORDIDX=+$PIECE($GET(^PS(53.1,IDX,.2)),U)

                                           End DoDot:4

 +94                                   IF ID="U;I"

                                           Begin DoDot:4

 +95      ; IA 4826

                                               DO PSS431^PSS55(DFN,IDX,"","","TIULMED")

 +96                                           IF +$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))=1

                                                   Begin DoDot:5

 +97                                                   SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))

                                                       IF TMPIDX'>0

                                                           QUIT 

 +98                                                   SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",TMPIDX,.01))

                                                   End DoDot:5

 +99                                           SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,108))

                                           End DoDot:4

 +100                                  IF ID="V;I"

                                           Begin DoDot:4

 +101     ; IA 4826

                                               DO PSS436^PSS55(DFN,IDX,"TIULMED")

 +102     ; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX

 +103                                          SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,130))

 +104                                          IF ^TMP($JOB,"TIULMED",IDX,"ADD",0)=1

                                                   Begin DoDot:5

 +105                                                  SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"ADD",0))

                                                       IF +TMPIDX

                                                           Begin DoDot:6

 +106                                                          SET TMPIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"ADD",TMPIDX,.01))

 +107     ; IA 4662

                                                               IF +TMPIDX

                                                                   SET DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX)

                                                           End DoDot:6

                                                   End DoDot:5

                                           End DoDot:4

 +108                                  IF KEEPMED

                                           IF +DRUGIDX=0

                                               IF +ORDIDX

                                                   Begin DoDot:4

 +109                                                  SET IDX=0

                                                       SET ISSUPPLY=2

                                                       SET SDONE=+SUPPLIES

 +110                                                  NEW LIST

                                                       SET LIST="TIULMED"

                                                       KILL ^TMP($JOB,LIST)

 +111     ; IA 4662

                                                       DO DRGIEN^PSS50P7(ORDIDX,"",LIST)

 +112                                                  FOR 

                                                           SET IDX=$ORDER(^TMP($JOB,LIST,IDX))

                                                           IF 'IDX

                                                               QUIT 

                                                           Begin DoDot:5

 +113                                                          SET TMPCLASS=$$DRGCLASS^TIULMED2(IDX)

 +114                                                          SET TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)

 +115                                                          IF 'SDONE

                                                                   Begin DoDot:6

 +116                                                                  SET ISSUPPLY=(($EXTRACT(TMPCLASS,1,2)="XA")&($PIECE(TMPNODE,U,3)["S"))

 +117                                                                  IF 'ISSUPPLY

                                                                           SET SDONE=1

                                                                   End DoDot:6

                                                           End DoDot:5

                                                           IF (SDONE)

                                                               QUIT 

 +118                                                  IF 'SUPPLIES

                                                           IF (ISSUPPLY=1)

                                                               SET KEEPMED=0

                                                   End DoDot:4

                                   End DoDot:3

 +119                      IF AUTO=1

                               Begin DoDot:3

 +120                              SET ERX=$PIECE($GET(^PSRX(RXNO,999999921)),U,4)

 +121                              IF +ERX

                                       SET ERX=ERX_";"_RXNO

 +122                              SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,9)=STATUS_" (X)"

                               End DoDot:3

                       End DoDot:2

 +123     ;

 +124     ; *** Save wanted meds in "B" temp xref, removing duplicates ***

 +125     ;

 +126              IF KEEPMED

                       Begin DoDot:2

 +127     ; Get XSTR to check for duplicates

                           DO ADDMED^BTIUMED1(1)

 +128                      SET IDATE=$PIECE(NODE,U,15)

 +129                      SET OK='$DATA(@TARGET@("B",MED,XSTR))

 +130                      IF 'OK

                               IF (IDATE>@TARGET@("B",MED,XSTR))

                                   SET OK=1

 +131     ;Get the clinical indication

 +132     ;Patch 1016 changes

 +133                      SET HIEN=$PIECE(NODE,U)

 +134                      IF HIEN["R"

                               Begin DoDot:3

 +135                              SET HIEN=+HIEN

 +136                              SET INDIC=$$GET1^DIQ(52,HIEN,9999999.21,"E")

 +137                              IF INDIC=""

                                       SET INDIC="Clinical Indication Unknown"

                               End DoDot:3

 +138                      IF HIEN["P"

                               SET INDIC="Clinical Indication Unknown"

 +139                      IF HIEN["N"

                               SET INDIC="Clinical Indication Unknown"

 +140                      SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" "_INDIC

 +141                      IF OK

                               Begin DoDot:3

 +142                              SET @TARGET@("B",MED,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATUS_U_TYPE_U_CHRONIC_U_INDIC_U_ERX

 +143                              SET EMPTY=0

 +144                              IF DRUGCLAS=" "

                                       SET UNKNOWNS=1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +145     ;

 +146     ; *** Check for empty condition ***

 +147     ;

 +148      IF EMPTY

               Begin DoDot:1

 +149              DO ADD^BTIUMED1("No Medications Found")

 +150              DO ADD^BTIUMED1(" ")

               End DoDot:1

               GOTO LISTX

 +151     ;

 +152     ; *** Sort Meds in "C" temp xref - sort by Status,MedType,

 +153     ;     Med Name, and reverse issue date, followed by a counter

 +154     ;     to avoid erasing meds issued on the same day

 +155     ;

 +156      SET MED=""

           SET CNT=1000000

 +157      FOR 

               SET MED=$ORDER(@TARGET@("B",MED))

               IF MED=""

                   QUIT 

               Begin DoDot:1

 +158              SET XSTR=""

 +159              FOR 

                       SET XSTR=$ORDER(@TARGET@("B",MED,XSTR))

                       IF XSTR=""

                           QUIT 

                       Begin DoDot:2

 +160                      SET NODE=@TARGET@("B",MED,XSTR)

 +161                      SET DATA=MED_U_$PIECE(NODE,U,3)_U_$PIECE(NODE,U,5)

                           SET CNT=CNT+1

 +162                      SET STATUS=$PIECE(NODE,U,4)

 +163                      SET INDIC=$PIECE(NODE,U,7)

 +164                      SET @TARGET@("C",INDIC,STATUS,DATA,(9999999-$PIECE(NODE,U))_CNT)=$PIECE(NODE,U,2)_U_$PIECE(NODE,U,5)_U_$PIECE(NODE,U,6)_U_$PIECE(NODE,U,8)

                       End DoDot:2

               End DoDot:1

 +165      KILL @TARGET@("B")

 +166     ;

 +167     ; Read sorted data and save final version to TARGET

 +168     ;

 +169      SET (DATA,LSTINDIC)=""

           SET (LASTMEDT,COUNT,TOTAL)=0

 +170      SET $PIECE(SPACE60," ",60)=" "

           SET $PIECE(DASH73,"=",73)="="

 +171      DO WARNING^BTIUMED1

 +172      SET (STATUS,INDIC,DATA)=""

 +173      FOR 

               SET INDIC=$ORDER(@TARGET@("C",INDIC))

               IF INDIC=""

                   QUIT 

               Begin DoDot:1

 +174              FOR 

                       SET STATUS=$ORDER(@TARGET@("C",INDIC,STATUS))

                       IF STATUS=""

                           QUIT 

                       Begin DoDot:2

 +175                      FOR 

                               SET DATA=$ORDER(@TARGET@("C",INDIC,STATUS,DATA))

                               IF DATA=""

                                   QUIT 

                               Begin DoDot:3

 +176                              SET MEDTYPE=$PIECE(DATA,U,2)

 +177                              SET DRUGCLAS=$PIECE(DATA,U,2)

                                   SET MED=$PIECE(DATA,U,3)

                                   SET CNT=""

 +178                              FOR 

                                       SET CNT=$ORDER(@TARGET@("C",INDIC,STATUS,DATA,CNT))

                                       IF CNT=""

                                           QUIT 

                                       Begin DoDot:4

 +179                                      SET INDEX=@TARGET@("C",INDIC,STATUS,DATA,CNT)

 +180                                      SET TYPE=$PIECE(INDEX,U,2)

                                           SET CHRONIC=$PIECE(INDEX,U,3)

                                           SET ERX=$PIECE(INDEX,U,4)

                                           SET INDEX=+INDEX

 +181                                      SET NODE=^TMP("PS",$JOB,INDEX,0)

 +182     ;IHS/MSC/MGH  Patch 1010

 +183                                      IF STATUS="OUTSIDE"

                                               SET $PIECE(NODE,U,9)=STATUS

 +184     ;If hold meds, find the reason and add it to the node data

 +185                                      IF STATUS="HOLD"

                                               Begin DoDot:5

 +186                                              SET HIEN=+($PIECE(NODE,U))

 +187                                              SET REASON=$$GET1^DIQ(52,HIEN,99,"E")

 +188                                              SET NODE=NODE_U_REASON

                                               End DoDot:5

 +189                                      IF ERX'=""

                                               SET $PIECE(NODE,U,31)=ERX

 +190     ;I (MEDTYPE'=LASTMEDT)!(STATUS'=LASTSTS)!(INDIC'=LSTINDIC) D  ; Create Header

 +191     ; Create Header

                                           IF (INDIC'=LSTINDIC)

                                               Begin DoDot:5

 +192                                              IF 'HEADER

                                                       QUIT 

 +193                                              SET LSTINDIC=INDIC

                                                   SET TAB=0

 +194                                              IF COUNT>0

                                                       DO ADD^BTIUMED1(" ")

 +195                                              SET COUNT=0

 +196                                              IF MEDTYPE=OUTPTYPE

                                                       Begin DoDot:6

 +197     ;D ADD^BTIUMED1(SPACE60_"Issue Date")

 +198     ;D ADD^BTIUMED1(SPACE60)

 +199     ;I STATUS="OUTSIDE" D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60))

 +200                                                      DO ADD^BTIUMED1($EXTRACT($EXTRACT(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")

                                                       End DoDot:6

                                                       IF 1

 +201                                              SET TEMP=INDIC_" "

 +202     ;S TEMP=$S(STATIDX=1:"Active",STATIDX=2:"Pending",1:"Inactive")_" "

 +203     ;S TEMP=TEMP_$S(MEDTYPE=INPTYPE:"Inpatient",1:"Outpatient")

 +204     ;S TEMP="     "_TEMP_" Medications"

 +205                                              SET TEMP=$EXTRACT(TEMP_SPACE60,1,47)

 +206                                              IF MEDTYPE=INPTYPE

                                                       SET TEMP=TEMP_"Status"