TIULMED3 ; SLC/MAM - Cont. of Active/Recent Med Objects Routine ;03/22/17 07:22
;;1.0;TEXT INTEGRATION UTILITIES;**198,213,290**;Jun 20, 1997;Build 548
GETCLASS ; Get Drug Class, filter out supplies BP/ELR
I +DRUGIDX D
.N TEMPNODE
.S DRUGCLAS=$$DRGCLASS^TIULMED2(DRUGIDX)
.S TEMPNODE=U_DRUGCLAS_U_$$DEA^TIULMED2(DRUGIDX)
.I 'SUPPLIES,($E(DRUGCLAS,1,2)="XA") D
..S KEEPMED='($P(TEMPNODE,U,3)["S")
Q
;
PATCHSOK() ; Function Checks for Pharmacy Package and required patches
;Returns 1 if ok, 0 if not
N CHECKOK S CHECKOK=1
I '$L($T(OCL^PSOORRL)) D S CHECKOK=0 G CKX
. D ADD^TIULMED1("Outpatient Pharmacy 7.0 Required for this Object.")
. D ADD^TIULMED1(" ")
I '$$PATCH^XPDUTL("PSO*7.0*20") D S CHECKOK=0 G CKX
. D ADD^TIULMED1("Outpatient Pharmacy Patch PSO*7.0*20 is required for this Object.")
. D ADD^TIULMED1(" ")
I '$$PATCH^XPDUTL("PSJ*5.0*22") D S CHECKOK=0 G CKX
. D ADD^TIULMED1("Inpatient Pharmacy Patch PSJ*5.0*22 is required for this Object.")
. D ADD^TIULMED1(" ")
CKX Q CHECKOK
;
SORTSAVE ;Sort & save Meds Data in TARGET
; *** Check for empty condition ***
;
I EMPTY D G SORTX
.D ADD^TIULMED1("No Medications Found")
.D ADD^TIULMED1(" ")
;
; *** Sort Meds in "C" temp xref - sort by Med Type, Status
; Med Name, and reverse issue date, followed by a counter
; to avoid erasing meds issued on the same day
N MED,CNT,XSTR,TIUXSTAT
N DATA,NODE
S MED="",CNT=1000000
F S MED=$O(@TARGET@("B",MED)) Q:MED="" D
.S (XSTR,TIUXSTAT)=""
.F S XSTR=$O(@TARGET@("B",MED,XSTR)) Q:XSTR="" D
.. F S TIUXSTAT=$O(@TARGET@("B",MED,XSTR,TIUXSTAT)) Q:TIUXSTAT="" D
...S NODE=@TARGET@("B",MED,XSTR,TIUXSTAT)
...S DATA=$P(NODE,U,3)_U_$P(NODE,U,5)_U_MED,CNT=CNT+1
...; ajb 290
... D
.... N CLINORD,NODE0,ORDNUM
.... S CLINORD=0,NODE0=^TMP("PS",$J,$P(NODE,U,2),0)
.... S ORDNUM=$P(NODE0,U,8)
.... D ISCLORD^ORUTL(.CLINORD,ORDNUM)
.... I +CLINORD S $E(DATA)=0
...; ajb 290
...S @TARGET@("C",DATA,(9999999-$P(NODE,U))_CNT)=$P(NODE,U,2)_U_$P(NODE,U,4)
;
; Read sorted data and save final version to TARGET
;
N LASTCLAS,LASTMEDT,LASTSTS,COUNT,TOTAL
N INDEX,MEDTYPE,STATIDX,DRUGCLAS,TYPE
N NODE,LASTMEDT,LASTSTS,TEMP,OLDTAB,OLDHEADR
S (DATA,LASTCLAS)="",(LASTMEDT,LASTSTS,COUNT,TOTAL)=0
D WARNING^TIULMED1
F S DATA=$O(@TARGET@("C",DATA)) Q:DATA="" D
.N CLINORD S CLINORD=$S($E(DATA)=0:1,1:0)
.S MEDTYPE=$E(DATA),STATIDX=$E(DATA,2)
.S DRUGCLAS=$P(DATA,U,2),MED=$P(DATA,U,3),CNT=""
.F S CNT=$O(@TARGET@("C",DATA,CNT)) Q:CNT="" D
..S INDEX=@TARGET@("C",DATA,CNT)
..S TYPE=$P(INDEX,U,2),INDEX=+INDEX
..S NODE=^TMP("PS",$J,INDEX,0)
..I $P($P(NODE,U),";")["N" S $P(NODE,U,2)="Non-VA "_$P(NODE,U,2)
..I (MEDTYPE'=LASTMEDT)!(STATIDX'=LASTSTS) D ; Create Header
...I CLASSORT'=2,DRUGCLAS'=" " S LASTCLAS=DRUGCLAS
...I 'HEADER Q
...S LASTMEDT=MEDTYPE,LASTSTS=STATIDX,TAB=0
...I COUNT>0 D ADD^TIULMED1(" ")
...I CLASSORT D ADD^TIULMED1(" ")
...S COUNT=0
...I DETAILED D
....I MEDTYPE=OUTPTYPE D I 1
.....D ADD^TIULMED1(SPACE60_"Issue Date")
.....D ADD^TIULMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
....E D ADD^TIULMED1(SPACE60_"Start Date")
...I 'ONELIST D
....S TEMP=$S(STATIDX=1:"Active",STATIDX=2:"Pending",1:"Inactive")_" "
...E S TEMP=""
...S TEMP=TEMP_$S(+CLINORD:"Clinic",MEDTYPE=INPTYPE:"Inpatient",MEDTYPE=NVATYPE:"Non-VA",1:"Outpatient") ; ajb 290
...S TEMP=" "_TEMP_" Medications" I ALLMEDS=4 S TEMP=TEMP_" and Infusions"
...I CLASSORT D
....I DETAILED S TEMP=TEMP_" (By Class)"
....E S TEMP=TEMP_" (By Drug Class)"
...I DETAILED D I 1
....S TEMP=$E(TEMP_SPACE60,1,47)
....I MEDTYPE=INPTYPE!(+CLINORD) S TEMP=TEMP_"Status" ; ajb 290
....E S TEMP=TEMP_"Refills"
....S TEMP=$E(TEMP_SPACE60,1,60)
....I MEDTYPE=INPTYPE!(+CLINORD) S TEMP=TEMP_"Stop Date" ; ajb 290
....E S TEMP=TEMP_"Expiration"
...E D
....S TEMP=$E(TEMP_SPACE60,1,60)_"Status"
...D ADD^TIULMED1(TEMP),ADD^TIULMED1(DASH73)
..I CLASSORT,DRUGCLAS'="",DRUGCLAS'=LASTCLAS D
...S LASTCLAS=DRUGCLAS,OLDTAB=TAB,OLDHEADR=HEADER
...S (TAB,HEADER)=0
...I COUNT>0 D ADD^TIULMED1(" ")
...I (CLASSORT=2)!(DRUGCLAS=" ") D I 1
....I DRUGCLAS=" " S TEMP=" ====== Drug Class Unknown "
....E S TEMP=" ====== Drug Class: "_DRUGCLAS_" "
...E S TEMP=" "
...S TEMP=$E(TEMP_DASH73,1,LLEN-2)
...D ADD^TIULMED1(TEMP)
...S HEADER=OLDHEADR,TAB=OLDTAB
..S COUNT=COUNT+1,TOTAL=TOTAL+1
..D ADDMED^TIULMED1(0)
I COUNT'=TOTAL D
.S TAB=0
.D ADD^TIULMED1(" ")
.D ADD^TIULMED1(TOTAL_" Total Medications")
SORTX ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULMED3 4619 printed Apr 09, 2024@21:42:22 Page 2
TIULMED3 ; SLC/MAM - Cont. of Active/Recent Med Objects Routine ;03/22/17 07:22
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**198,213,290**;Jun 20, 1997;Build 548
GETCLASS ; Get Drug Class, filter out supplies BP/ELR
+1 IF +DRUGIDX
Begin DoDot:1
+2 NEW TEMPNODE
+3 SET DRUGCLAS=$$DRGCLASS^TIULMED2(DRUGIDX)
+4 SET TEMPNODE=U_DRUGCLAS_U_$$DEA^TIULMED2(DRUGIDX)
+5 IF 'SUPPLIES
IF ($EXTRACT(DRUGCLAS,1,2)="XA")
Begin DoDot:2
+6 SET KEEPMED='($PIECE(TEMPNODE,U,3)["S")
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
PATCHSOK() ; Function Checks for Pharmacy Package and required patches
+1 ;Returns 1 if ok, 0 if not
+2 NEW CHECKOK
SET CHECKOK=1
+3 IF '$LENGTH($TEXT(OCL^PSOORRL))
Begin DoDot:1
+4 DO ADD^TIULMED1("Outpatient Pharmacy 7.0 Required for this Object.")
+5 DO ADD^TIULMED1(" ")
End DoDot:1
SET CHECKOK=0
GOTO CKX
+6 IF '$$PATCH^XPDUTL("PSO*7.0*20")
Begin DoDot:1
+7 DO ADD^TIULMED1("Outpatient Pharmacy Patch PSO*7.0*20 is required for this Object.")
+8 DO ADD^TIULMED1(" ")
End DoDot:1
SET CHECKOK=0
GOTO CKX
+9 IF '$$PATCH^XPDUTL("PSJ*5.0*22")
Begin DoDot:1
+10 DO ADD^TIULMED1("Inpatient Pharmacy Patch PSJ*5.0*22 is required for this Object.")
+11 DO ADD^TIULMED1(" ")
End DoDot:1
SET CHECKOK=0
GOTO CKX
CKX QUIT CHECKOK
+1 ;
SORTSAVE ;Sort & save Meds Data in TARGET
+1 ; *** Check for empty condition ***
+2 ;
+3 IF EMPTY
Begin DoDot:1
+4 DO ADD^TIULMED1("No Medications Found")
+5 DO ADD^TIULMED1(" ")
End DoDot:1
GOTO SORTX
+6 ;
+7 ; *** Sort Meds in "C" temp xref - sort by Med Type, Status
+8 ; Med Name, and reverse issue date, followed by a counter
+9 ; to avoid erasing meds issued on the same day
+10 NEW MED,CNT,XSTR,TIUXSTAT
+11 NEW DATA,NODE
+12 SET MED=""
SET CNT=1000000
+13 FOR
SET MED=$ORDER(@TARGET@("B",MED))
if MED=""
QUIT
Begin DoDot:1
+14 SET (XSTR,TIUXSTAT)=""
+15 FOR
SET XSTR=$ORDER(@TARGET@("B",MED,XSTR))
if XSTR=""
QUIT
Begin DoDot:2
+16 FOR
SET TIUXSTAT=$ORDER(@TARGET@("B",MED,XSTR,TIUXSTAT))
if TIUXSTAT=""
QUIT
Begin DoDot:3
+17 SET NODE=@TARGET@("B",MED,XSTR,TIUXSTAT)
+18 SET DATA=$PIECE(NODE,U,3)_U_$PIECE(NODE,U,5)_U_MED
SET CNT=CNT+1
+19 ; ajb 290
+20 Begin DoDot:4
+21 NEW CLINORD,NODE0,ORDNUM
+22 SET CLINORD=0
SET NODE0=^TMP("PS",$JOB,$PIECE(NODE,U,2),0)
+23 SET ORDNUM=$PIECE(NODE0,U,8)
+24 DO ISCLORD^ORUTL(.CLINORD,ORDNUM)
+25 IF +CLINORD
SET $EXTRACT(DATA)=0
End DoDot:4
+26 ; ajb 290
+27 SET @TARGET@("C",DATA,(9999999-$PIECE(NODE,U))_CNT)=$PIECE(NODE,U,2)_U_$PIECE(NODE,U,4)
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 ; Read sorted data and save final version to TARGET
+30 ;
+31 NEW LASTCLAS,LASTMEDT,LASTSTS,COUNT,TOTAL
+32 NEW INDEX,MEDTYPE,STATIDX,DRUGCLAS,TYPE
+33 NEW NODE,LASTMEDT,LASTSTS,TEMP,OLDTAB,OLDHEADR
+34 SET (DATA,LASTCLAS)=""
SET (LASTMEDT,LASTSTS,COUNT,TOTAL)=0
+35 DO WARNING^TIULMED1
+36 FOR
SET DATA=$ORDER(@TARGET@("C",DATA))
if DATA=""
QUIT
Begin DoDot:1
+37 NEW CLINORD
SET CLINORD=$SELECT($EXTRACT(DATA)=0:1,1:0)
+38 SET MEDTYPE=$EXTRACT(DATA)
SET STATIDX=$EXTRACT(DATA,2)
+39 SET DRUGCLAS=$PIECE(DATA,U,2)
SET MED=$PIECE(DATA,U,3)
SET CNT=""
+40 FOR
SET CNT=$ORDER(@TARGET@("C",DATA,CNT))
if CNT=""
QUIT
Begin DoDot:2
+41 SET INDEX=@TARGET@("C",DATA,CNT)
+42 SET TYPE=$PIECE(INDEX,U,2)
SET INDEX=+INDEX
+43 SET NODE=^TMP("PS",$JOB,INDEX,0)
+44 IF $PIECE($PIECE(NODE,U),";")["N"
SET $PIECE(NODE,U,2)="Non-VA "_$PIECE(NODE,U,2)
+45 ; Create Header
IF (MEDTYPE'=LASTMEDT)!(STATIDX'=LASTSTS)
Begin DoDot:3
+46 IF CLASSORT'=2
IF DRUGCLAS'=" "
SET LASTCLAS=DRUGCLAS
+47 IF 'HEADER
QUIT
+48 SET LASTMEDT=MEDTYPE
SET LASTSTS=STATIDX
SET TAB=0
+49 IF COUNT>0
DO ADD^TIULMED1(" ")
+50 IF CLASSORT
DO ADD^TIULMED1(" ")
+51 SET COUNT=0
+52 IF DETAILED
Begin DoDot:4
+53 IF MEDTYPE=OUTPTYPE
Begin DoDot:5
+54 DO ADD^TIULMED1(SPACE60_"Issue Date")
+55 DO ADD^TIULMED1($EXTRACT($EXTRACT(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
End DoDot:5
IF 1
+56 IF '$TEST
DO ADD^TIULMED1(SPACE60_"Start Date")
End DoDot:4
+57 IF 'ONELIST
Begin DoDot:4
+58 SET TEMP=$SELECT(STATIDX=1:"Active",STATIDX=2:"Pending",1:"Inactive")_" "
End DoDot:4
+59 IF '$TEST
SET TEMP=""
+60 ; ajb 290
SET TEMP=TEMP_$SELECT(+CLINORD:"Clinic",MEDTYPE=INPTYPE:"Inpatient",MEDTYPE=NVATYPE:"Non-VA",1:"Outpatient")
+61 SET TEMP=" "_TEMP_" Medications"
IF ALLMEDS=4
SET TEMP=TEMP_" and Infusions"
+62 IF CLASSORT
Begin DoDot:4
+63 IF DETAILED
SET TEMP=TEMP_" (By Class)"
+64 IF '$TEST
SET TEMP=TEMP_" (By Drug Class)"
End DoDot:4
+65 IF DETAILED
Begin DoDot:4
+66 SET TEMP=$EXTRACT(TEMP_SPACE60,1,47)
+67 ; ajb 290
IF MEDTYPE=INPTYPE!(+CLINORD)
SET TEMP=TEMP_"Status"
+68 IF '$TEST
SET TEMP=TEMP_"Refills"
+69 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)
+70 ; ajb 290
IF MEDTYPE=INPTYPE!(+CLINORD)
SET TEMP=TEMP_"Stop Date"
+71 IF '$TEST
SET TEMP=TEMP_"Expiration"
End DoDot:4
IF 1
+72 IF '$TEST
Begin DoDot:4
+73 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)_"Status"
End DoDot:4
+74 DO ADD^TIULMED1(TEMP)
DO ADD^TIULMED1(DASH73)
End DoDot:3
+75 IF CLASSORT
IF DRUGCLAS'=""
IF DRUGCLAS'=LASTCLAS
Begin DoDot:3
+76 SET LASTCLAS=DRUGCLAS
SET OLDTAB=TAB
SET OLDHEADR=HEADER
+77 SET (TAB,HEADER)=0
+78 IF COUNT>0
DO ADD^TIULMED1(" ")
+79 IF (CLASSORT=2)!(DRUGCLAS=" ")
Begin DoDot:4
+80 IF DRUGCLAS=" "
SET TEMP=" ====== Drug Class Unknown "
+81 IF '$TEST
SET TEMP=" ====== Drug Class: "_DRUGCLAS_" "
End DoDot:4
IF 1
+82 IF '$TEST
SET TEMP=" "
+83 SET TEMP=$EXTRACT(TEMP_DASH73,1,LLEN-2)
+84 DO ADD^TIULMED1(TEMP)
+85 SET HEADER=OLDHEADR
SET TAB=OLDTAB
End DoDot:3
+86 SET COUNT=COUNT+1
SET TOTAL=TOTAL+1
+87 DO ADDMED^TIULMED1(0)
End DoDot:2
End DoDot:1
+88 IF COUNT'=TOTAL
Begin DoDot:1
+89 SET TAB=0
+90 DO ADD^TIULMED1(" ")
+91 DO ADD^TIULMED1(TOTAL_" Total Medications")
End DoDot:1
SORTX ;
+1 QUIT
