PSGAH ;ALB/DRP - ADMINISTRATION HISTORY RPT ;29 Oct 2015 12:44 PM
;;5.0;INPATIENT MEDICATIONS;**315,350**;16 DEC 97;Build 3
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;Call to MEDHIST^PSBUTL controlled by IA 6271
;
Q
;Routine is called by Hidden Actions Menu so DFN variable will be passed in from the Menu
INIT ; Initialize Variables
I '$$PATCH^XPDUTL("PSB*3.0*83") W !,"Report not available until install of patch PSB*3.0*83" S TERM=1 D PAUSE Q
I ($G(ON)["V") W !,"AH Report cannot be run for this order. Use CPRS or BCMA to find Admin history." S TERM=1 D PAUSE Q
I ($G(ON)["P"),$P($G(^PS(53.1,+ON,0)),U,4)'["U" W !,"AH Report cannot be run for this order. Use CPRS or BCMA to find Admin history." S TERM=1 D PAUSE Q
Q:$G(DFN)=""
N PSGACAR,PSGQ,PSGORD,PSGOIEN,PSGSPCE,PSGMRT,PSGSCH,PSGDRNG,PSGLOC
N TERM,PSGACT,COUNT,PAGNO,PSGDSG,PSGIN
N $ESTACK,$ETRAP S $ETRAP="D ERRTRP^PSGAH" ;
S PSGOIEN=$G(PSGOPD) Q:'PSGOIEN
S $P(PSGSPCE," ",30)="",COUNT=0
D ENCV^PSGSETU Q:$D(XQUIT)
D FULL^VALM1,PRMTRNG,MAIN
K ^XTMP("PSGAH",$J)
Q
;
MAIN ; Main control
Q:$G(PSGQ)
D OPEN^%ZISUTL("PSGAH",,) I $G(POP) W !!,"Nothing queued to print.",! Q
S:$E(IOSL,1)'["9" TERM=$S($E($G(IOST),1,2)="C-":1,1:0)
U IO S PAGNO=0
;Get OI then get all orders for OI within time frame determined by ?
D GETHIST D:$D(PSGACAR) GETORD
D PRNHDR,WRITE
W !!,"Press RETURN to continue....." R X:$G(DTIME) ;pause before returning to Detail screen
D CLOSE^%ZISUTL("PSGAH")
K POP
Q
;
GETORD ; Get order information
N I,STR,PSGCUR S I=0
F S I=$O(PSGACAR(I)) Q:'I D
. S STR=PSGACAR(I),PSGCUR=0,PSGIN=$P(STR,U,6),PSGLOC=$P(STR,U,5)
. Q:$P(STR,U,3)["V"
. S PSGORD=+$P(STR,U,3),PSGACT=$P(STR,U,2) S:PSGORD=+$G(ON) PSGCUR=1 ;ON passed in from Menu
. S PSGMRT=$P($G(^PS(55,DFN,5,PSGORD,0)),U,3),PSGMRT=$P(^PS(51.2,PSGMRT,0),U,1)
. S PSGSCH=$P($G(^PS(55,DFN,5,PSGORD,2)),U,1)
. S PSGDSG=$P($G(^PS(55,DFN,5,PSGORD,.2)),U,2)
. D SETTMP(I) ;check and then set ^XTMP for sort
.Q
Q
;
GETHIST ; Get last 99 actions for each OI Dosage
;MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
; Input:
; DFN - Patient num
; OI - Inpatient Meds Orderable Item ien
; MAX - Max days back to search
; Output:
; LIST - Array of actions formatted as :
; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
D MEDHIST^PSBUTL(.PSGACAR,DFN,PSGOIEN,PSGDRNG) ;ZW PSGACAR
Q
;
;The following items were requested for this new report:
;Dose.
;All administrations for the Orderable Item
;Sorted by time.
;Grouped by all administrations by orderable item for that patient.
SETTMP(ORDDT) ; Builds ^XTMP for sort
S ^XTMP("PSGAH",$J,ORDDT,PSGORD)=PSGDSG_U_PSGMRT_U_PSGSCH_$S(PSGCUR:"-Current",1:"")_U_PSGACT_U_PSGIN_U_PSGLOC
Q
;
WRITE ; WRITE records to output
; "DOSAGE ORDERD"_" "_MED ROUTE (INTERNAL)_" "_SCHEDULE(INTERNAL)_$S(CURRENT ORDER:"(*)",1:"")
N DATE,ORDER,STR S DATE=9999999
F S DATE=$O(^XTMP("PSGAH",$J,DATE),-1) Q:DATE=""!$G(PSGQ) D
. S ORDER=0
. F S ORDER=$O(^XTMP("PSGAH",$J,DATE,ORDER)) Q:ORDER=""!$G(PSGQ) D
..S STR=^XTMP("PSGAH",$J,DATE,ORDER),PSGDSG=$P(STR,U,1),PSGMRT=$P(STR,U,2),PSGSCH=$P(STR,U,3),PSGACT=$P(STR,U,4)
..S PSGIN=$P(STR,U,5),PSGLOC=$P(STR,U,6)
..D PRNLN
..Q
.Q
Q
;
PRNHDR ; Heading
Q:$G(PSGQ)
S PAGNO=PAGNO+1
W @IOF
W ! W:'$G(TERM) ?5 W $E($$FMTE^XLFDT($$NOW^XLFDT),1,18)
W ! W:'$G(TERM) ?5 W "Administration History for Orderable Item ",?73,"Page ",PAGNO
W ! W:'$G(TERM) ?10 W $G(PSGOPDN)
W ! W:'$G(TERM) ?5 W "Date Action Initials Location"
W ! W:'$G(TERM) ?8 W "Dosage Ordered Med Route Schedule"
W ! W:'$G(TERM) ?5 W "---------------------------------------------------------------------------"
Q
;
PRNLN ;Write line on report
;N ACTLBL S ACTLBL=$S(COUNT:"PREVIOUS ACTION "_COUNT_" ",1:"LAST ACTION: ")
W ! W:'$G(TERM) ?5 W $E($P($$FMTE^XLFDT(DATE,5),":",1,2)_PSGSPCE,1,16)_" "_$E(PSGACT_PSGSPCE,1,6)_" "_$E(PSGIN_PSGSPCE,1,8)_" "_$G(PSGLOC,"UNKNOWN")
W ! W:'$G(TERM) ?8 W $E(PSGDSG_PSGSPCE,1,30)_" "_$E(PSGMRT_PSGSPCE,1,12)_" "_$E(PSGSCH_PSGSPCE,1,30),!
S COUNT=COUNT+1
I $Y>(IOSL-2) D:$G(TERM) PAUSE D PRNHDR
Q
;
PAUSE Q:'($G(TERM))
N X
U IO(0) W !!,"Press RETURN to continue, '^' to exit"
R X:$G(DTIME) I (X="^")!('$T) S PSGQ=1 Q
U IO
Q
PRMTRNG ; prompt for number of Days back to return
K DIR,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="N^1:99999:0"
S DIR("A")="Enter Number of days back to search",DIR("B")="14"
S DIR("?")="Enter an '^' to exit this option now."
S DIR("?",1)="Enter the number days prior to today to search the BCMA MEDICATION LOG"
S DIR("?",2)="All BCMA orders within indicated range will be included"
S DIR("?",3)=""
S DIR("?",4)=""
D ^DIR S PSGDRNG=$S($D(DIRUT):0,1:Y) S:$D(DIRUT) PSGQ=1
K DIR,DIRUT,Y
Q
;
ERRTRP ; Error trap processing
N Z,PROBLEM
S Z(1,1)=$$EC^%ZOSV ; mumps error location and description
S Z="A SYSTEM ERROR HAS BEEN DETECTED AT THE FOLLOWING LOCATION"
S PROBLEM=7
D ^%ZTER ; record the error in the trap
G UNWIND^%ZTER ; unwind stack levels
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAH 5241 printed Sep 23, 2025@19:36:48 Page 2
PSGAH ;ALB/DRP - ADMINISTRATION HISTORY RPT ;29 Oct 2015 12:44 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**315,350**;16 DEC 97;Build 3
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 ;Call to MEDHIST^PSBUTL controlled by IA 6271
+5 ;
+6 QUIT
+7 ;Routine is called by Hidden Actions Menu so DFN variable will be passed in from the Menu
INIT ; Initialize Variables
+1 IF '$$PATCH^XPDUTL("PSB*3.0*83")
WRITE !,"Report not available until install of patch PSB*3.0*83"
SET TERM=1
DO PAUSE
QUIT
+2 IF ($GET(ON)["V")
WRITE !,"AH Report cannot be run for this order. Use CPRS or BCMA to find Admin history."
SET TERM=1
DO PAUSE
QUIT
+3 IF ($GET(ON)["P")
IF $PIECE($GET(^PS(53.1,+ON,0)),U,4)'["U"
WRITE !,"AH Report cannot be run for this order. Use CPRS or BCMA to find Admin history."
SET TERM=1
DO PAUSE
QUIT
+4 if $GET(DFN)=""
QUIT
+5 NEW PSGACAR,PSGQ,PSGORD,PSGOIEN,PSGSPCE,PSGMRT,PSGSCH,PSGDRNG,PSGLOC
+6 NEW TERM,PSGACT,COUNT,PAGNO,PSGDSG,PSGIN
+7 ;
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERRTRP^PSGAH"
+8 SET PSGOIEN=$GET(PSGOPD)
if 'PSGOIEN
QUIT
+9 SET $PIECE(PSGSPCE," ",30)=""
SET COUNT=0
+10 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
+11 DO FULL^VALM1
DO PRMTRNG
DO MAIN
+12 KILL ^XTMP("PSGAH",$JOB)
+13 QUIT
+14 ;
MAIN ; Main control
+1 if $GET(PSGQ)
QUIT
+2 DO OPEN^%ZISUTL("PSGAH",,)
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!
QUIT
+3 if $EXTRACT(IOSL,1)'["9"
SET TERM=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+4 USE IO
SET PAGNO=0
+5 ;Get OI then get all orders for OI within time frame determined by ?
+6 DO GETHIST
if $DATA(PSGACAR)
DO GETORD
+7 DO PRNHDR
DO WRITE
+8 ;pause before returning to Detail screen
WRITE !!,"Press RETURN to continue....."
READ X:$GET(DTIME)
+9 DO CLOSE^%ZISUTL("PSGAH")
+10 KILL POP
+11 QUIT
+12 ;
GETORD ; Get order information
+1 NEW I,STR,PSGCUR
SET I=0
+2 FOR
SET I=$ORDER(PSGACAR(I))
if 'I
QUIT
Begin DoDot:1
+3 SET STR=PSGACAR(I)
SET PSGCUR=0
SET PSGIN=$PIECE(STR,U,6)
SET PSGLOC=$PIECE(STR,U,5)
+4 if $PIECE(STR,U,3)["V"
QUIT
+5 ;ON passed in from Menu
SET PSGORD=+$PIECE(STR,U,3)
SET PSGACT=$PIECE(STR,U,2)
if PSGORD=+$GET(ON)
SET PSGCUR=1
+6 SET PSGMRT=$PIECE($GET(^PS(55,DFN,5,PSGORD,0)),U,3)
SET PSGMRT=$PIECE(^PS(51.2,PSGMRT,0),U,1)
+7 SET PSGSCH=$PIECE($GET(^PS(55,DFN,5,PSGORD,2)),U,1)
+8 SET PSGDSG=$PIECE($GET(^PS(55,DFN,5,PSGORD,.2)),U,2)
+9 ;check and then set ^XTMP for sort
DO SETTMP(I)
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
GETHIST ; Get last 99 actions for each OI Dosage
+1 ;MEDHIST(LIST,DFN,OI,MAX) ;Last nn admin actions per a patients Orderable Item
+2 ; Input:
+3 ; DFN - Patient num
+4 ; OI - Inpatient Meds Orderable Item ien
+5 ; MAX - Max days back to search
+6 ; Output:
+7 ; LIST - Array of actions formatted as :
+8 ; DATE^ACTION^ORDNO^LSTSITE^LOCATION^NURSINITL
+9 ;ZW PSGACAR
DO MEDHIST^PSBUTL(.PSGACAR,DFN,PSGOIEN,PSGDRNG)
+10 QUIT
+11 ;
+12 ;The following items were requested for this new report:
+13 ;Dose.
+14 ;All administrations for the Orderable Item
+15 ;Sorted by time.
+16 ;Grouped by all administrations by orderable item for that patient.
SETTMP(ORDDT) ; Builds ^XTMP for sort
+1 SET ^XTMP("PSGAH",$JOB,ORDDT,PSGORD)=PSGDSG_U_PSGMRT_U_PSGSCH_$SELECT(PSGCUR:"-Current",1:"")_U_PSGACT_U_PSGIN_U_PSGLOC
+2 QUIT
+3 ;
WRITE ; WRITE records to output
+1 ; "DOSAGE ORDERD"_" "_MED ROUTE (INTERNAL)_" "_SCHEDULE(INTERNAL)_$S(CURRENT ORDER:"(*)",1:"")
+2 NEW DATE,ORDER,STR
SET DATE=9999999
+3 FOR
SET DATE=$ORDER(^XTMP("PSGAH",$JOB,DATE),-1)
if DATE=""!$GET(PSGQ)
QUIT
Begin DoDot:1
+4 SET ORDER=0
+5 FOR
SET ORDER=$ORDER(^XTMP("PSGAH",$JOB,DATE,ORDER))
if ORDER=""!$GET(PSGQ)
QUIT
Begin DoDot:2
+6 SET STR=^XTMP("PSGAH",$JOB,DATE,ORDER)
SET PSGDSG=$PIECE(STR,U,1)
SET PSGMRT=$PIECE(STR,U,2)
SET PSGSCH=$PIECE(STR,U,3)
SET PSGACT=$PIECE(STR,U,4)
+7 SET PSGIN=$PIECE(STR,U,5)
SET PSGLOC=$PIECE(STR,U,6)
+8 DO PRNLN
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
PRNHDR ; Heading
+1 if $GET(PSGQ)
QUIT
+2 SET PAGNO=PAGNO+1
+3 WRITE @IOF
+4 WRITE !
if '$GET(TERM)
WRITE ?5
WRITE $EXTRACT($$FMTE^XLFDT($$NOW^XLFDT),1,18)
+5 WRITE !
if '$GET(TERM)
WRITE ?5
WRITE "Administration History for Orderable Item ",?73,"Page ",PAGNO
+6 WRITE !
if '$GET(TERM)
WRITE ?10
WRITE $GET(PSGOPDN)
+7 WRITE !
if '$GET(TERM)
WRITE ?5
WRITE "Date Action Initials Location"
+8 WRITE !
if '$GET(TERM)
WRITE ?8
WRITE "Dosage Ordered Med Route Schedule"
+9 WRITE !
if '$GET(TERM)
WRITE ?5
WRITE "---------------------------------------------------------------------------"
+10 QUIT
+11 ;
PRNLN ;Write line on report
+1 ;N ACTLBL S ACTLBL=$S(COUNT:"PREVIOUS ACTION "_COUNT_" ",1:"LAST ACTION: ")
+2 WRITE !
if '$GET(TERM)
WRITE ?5
WRITE $EXTRACT($PIECE($$FMTE^XLFDT(DATE,5),":",1,2)_PSGSPCE,1,16)_" "_$EXTRACT(PSGACT_PSGSPCE,1,6)_" "_$EXTRACT(PSGIN_PSGSPCE,1,8)_" "_$GET(PSGLOC,"UNKNOWN")
+3 WRITE !
if '$GET(TERM)
WRITE ?8
WRITE $EXTRACT(PSGDSG_PSGSPCE,1,30)_" "_$EXTRACT(PSGMRT_PSGSPCE,1,12)_" "_$EXTRACT(PSGSCH_PSGSPCE,1,30),!
+4 SET COUNT=COUNT+1
+5 IF $Y>(IOSL-2)
if $GET(TERM)
DO PAUSE
DO PRNHDR
+6 QUIT
+7 ;
PAUSE if '($GET(TERM))
QUIT
+1 NEW X
+2 USE IO(0)
WRITE !!,"Press RETURN to continue, '^' to exit"
+3 READ X:$GET(DTIME)
IF (X="^")!('$TEST)
SET PSGQ=1
QUIT
+4 USE IO
+5 QUIT
PRMTRNG ; prompt for number of Days back to return
+1 KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="N^1:99999:0"
+3 SET DIR("A")="Enter Number of days back to search"
SET DIR("B")="14"
+4 SET DIR("?")="Enter an '^' to exit this option now."
+5 SET DIR("?",1)="Enter the number days prior to today to search the BCMA MEDICATION LOG"
+6 SET DIR("?",2)="All BCMA orders within indicated range will be included"
+7 SET DIR("?",3)=""
+8 SET DIR("?",4)=""
+9 DO ^DIR
SET PSGDRNG=$SELECT($DATA(DIRUT):0,1:Y)
if $DATA(DIRUT)
SET PSGQ=1
+10 KILL DIR,DIRUT,Y
+11 QUIT
+12 ;
ERRTRP ; Error trap processing
+1 NEW Z,PROBLEM
+2 ; mumps error location and description
SET Z(1,1)=$$EC^%ZOSV
+3 SET Z="A SYSTEM ERROR HAS BEEN DETECTED AT THE FOLLOWING LOCATION"
+4 SET PROBLEM=7
+5 ; record the error in the trap
DO ^%ZTER
+6 ; unwind stack levels
GOTO UNWIND^%ZTER
+7 QUIT
