PSGEUDD ;BIR/MV-EXTRA UNITS DISPENSED REPORT ;14 JAN 97 / 9:22 AM
;;5.0; INPATIENT MEDICATIONS ;**27,31,59,111**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191
; Reference to ^DIC(42 is supported by DBIA# 10039
;
NEW ;***New needed variables.
K ^TMP($J)
NEW AMT,DRG,ND,NO,PPN,TM,WHO,XDESC,XSAVE,XTRTN,PSJACNWP
;
ASK ;***Ask for date range and output device
Q:$$STDATE^PSJMDIR S PSGSDT=Y
K DIR S DIR(0)="DAO^"_PSGSDT_"::,EXAR",DIR("A")="Enter Ending Date and Time: ",DIR("?")="Please enter a date and time that is greater than the Start Date" D ^DIR S PSGEDT=Y Q:$$STOP^PSJMDIR
Q:$$GWP^PSJMDIR1(0)
Q:$$SELDEV^PSJMUTL
W:'$D(IO("Q")) !,"this may take a while...(you should QUEUE the Extra Units Dispensed report)"
;***Queue to sort in the background.
I $D(IO("Q")) D G EXIT
. S XDESC="Extra Unit Dose Dispensed (Sort)"
. ;Added PSGWGNM to XSAVE to enable printing of ward group total for queued prints
. S XSAVE="PSGWGNM;PSGSDT;PSGEDT;PSGSS;PSGIO;PSGWG;PSGWD;PSGWN;PSGTMALL;PSGTM;PSGPAT(;PSGP(;PSGIODOC"
. S XTRTN="START^PSGEUDD"
. D SETSORTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
D START
;
EXIT ;***Exit report here.
D ENKV^PSGSETU
D EXIT^PSJMUTL
K ^TMP($J),PSGDT,PSGEDT,PSGIO,PSGORD,PSGP,PSGPAT,PSGSDT,PSGSS,PSGTM,PSGTMALL,PSGWD,PSGWG,PSGWGNM,PSGWN,PSJSTOP
Q
START ;***Start queuing here.
D @PSGSS
;***Queue to the printer.
I $D(PSGIO) D G EXIT
. S XDESC="Extra Unit Dose Dispensed (Print)"
. S XSAVE="^TMP($J,;PSGWGNM;PSGTMALL;PSGTM;PSGSDT;PSGEDT;PSGSS;PSGIODOC"
. S XTRTN="^PSGEUDP"
. D SETPRTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
D ^PSGEUDP
Q
;
P ;***Select by Patient
S PPN="" F S PPN=$O(PSGPAT(PPN)) Q:PPN="" S PSGP=PSGPAT(PPN),PSJACNWP="" K PSJPPID,PSJPRB D ^PSJAC,LOOP
Q
;
C ;***Select by CLINIC
N DT,CLIN
S TM="ZZ",PSJACNWP=""
S DT=PSGSDT F S DT=$O(^PS(55,"AUDC",DT)) Q:DT>PSGEDT!(DT="") S CLIN=0 F S CLIN=$O(^PS(55,"AUDC",DT,CLIN)) Q:'CLIN D
.S PSGP=0 F S PSGP=$O(^PS(55,"AUDC",DT,CLIN,PSGP)) Q:'PSGP D ^PSJAC S PPN=PSGP(0) D LOOP
Q
G ;***Select by WARD GROUP
D WARDGP
Q
W ;***Select by Ward
D WARD
Q
WARDGP ;*** Find wards within a ward group
S PSGWD="",TM="ZZ" F S PSGWD=$O(^PS(57.5,"AC",PSGWG,PSGWD)) Q:'PSGWD I $D(^DIC(42,+PSGWD,0)) S PSGWN=$P(^(0),U) D WARD
Q
;
WARD ;*** Go through each patient within a given WARD
;*** Var used in PSJAC. Set to null to skip WP^PSJAC
S PSJACNWP=""
F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGWN,PSGP)) Q:'PSGP D ^PSJAC S PPN=PSGP(0) D:PSGSS="W" TEAM D:PSGSS="G" LOOP
Q
TEAM ;*** Look up selected team. PSGTMALL= All teams were selected.
S TM=""
I PSGTMALL D ALLTM,LOOP Q
I 'PSGTM S TM="ZZ" D LOOP Q
D ALLTM D:$D(PSGTM(TM)) LOOP
Q
;
ALLTM ;*** Get UNIT DOSE information from ^PS(55
;
S TM="ZZ"
S TM=$S(PSJPRB="":0,1:+$O(^PS(57.7,"AWRT",PSGWD,PSJPRB,0))),TM=$S('TM:"ZZ",'$D(^PS(57.7,PSGWD,1,TM,0)):TM,$P(^(0),U)]"":$P(^(0),U),1:TM)
Q
;
LOOP ;***Loop thru ^PS(55 on the Dispense log multiple.
F PSGORD=0:0 S PSGORD=$O(^PS(55,+PSGP,5,PSGORD)) Q:'PSGORD D
. S PSGDT=PSGSDT-.000001
. F S PSGDT=$O(^PS(55,+PSGP,5,+PSGORD,11,"B",PSGDT)) Q:'PSGDT!(PSGEDT<PSGDT) D
..F NO=0:0 S NO=$O(^PS(55,+PSGP,5,+PSGORD,11,"B",PSGDT,NO)) Q:'NO S ND=^PS(55,+PSGP,5,+PSGORD,11,NO,0) D
...I $P(ND,U,5)=3 S DRG=$$ENDDN^PSGMI($P(ND,U,2)),AMT=$P(ND,U,3),WHO=$P(ND,U,6) D @($S(PSGSS="P":"TMPPT",1:"TMPWG"))
Q
;
TMPWG ;***Set ^TMP global for selected by Ward/Ward Group.
S ^TMP($J,PSGWN,TM,DRG,$E(PPN,1,10)_"^"_+PSGP,PSGDT)=AMT_U_WHO_U_PSJPBID
Q
;
TMPPT ;***Set ^TMP global for selected by patient.
S ^TMP($J,$E(PPN,1,10)_"^"_+PSGP,DRG,PSGDT)=AMT_U_WHO_U_PSJPPID_U_PSJPRB_U_PSJPWDN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGEUDD 3678 printed Apr 09, 2024@21:04:43 Page 2
PSGEUDD ;BIR/MV-EXTRA UNITS DISPENSED REPORT ;14 JAN 97 / 9:22 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**27,31,59,111**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ; Reference to ^DIC(42 is supported by DBIA# 10039
+5 ;
NEW ;***New needed variables.
+1 KILL ^TMP($JOB)
+2 NEW AMT,DRG,ND,NO,PPN,TM,WHO,XDESC,XSAVE,XTRTN,PSJACNWP
+3 ;
ASK ;***Ask for date range and output device
+1 if $$STDATE^PSJMDIR
QUIT
SET PSGSDT=Y
+2 KILL DIR
SET DIR(0)="DAO^"_PSGSDT_"::,EXAR"
SET DIR("A")="Enter Ending Date and Time: "
SET DIR("?")="Please enter a date and time that is greater than the Start Date"
DO ^DIR
SET PSGEDT=Y
if $$STOP^PSJMDIR
QUIT
+3 if $$GWP^PSJMDIR1(0)
QUIT
+4 if $$SELDEV^PSJMUTL
QUIT
+5 if '$DATA(IO("Q"))
WRITE !,"this may take a while...(you should QUEUE the Extra Units Dispensed report)"
+6 ;***Queue to sort in the background.
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET XDESC="Extra Unit Dose Dispensed (Sort)"
+9 ;Added PSGWGNM to XSAVE to enable printing of ward group total for queued prints
+10 SET XSAVE="PSGWGNM;PSGSDT;PSGEDT;PSGSS;PSGIO;PSGWG;PSGWD;PSGWN;PSGTMALL;PSGTM;PSGPAT(;PSGP(;PSGIODOC"
+11 SET XTRTN="START^PSGEUDD"
+12 DO SETSORTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
End DoDot:1
GOTO EXIT
+13 DO START
+14 ;
EXIT ;***Exit report here.
+1 DO ENKV^PSGSETU
+2 DO EXIT^PSJMUTL
+3 KILL ^TMP($JOB),PSGDT,PSGEDT,PSGIO,PSGORD,PSGP,PSGPAT,PSGSDT,PSGSS,PSGTM,PSGTMALL,PSGWD,PSGWG,PSGWGNM,PSGWN,PSJSTOP
+4 QUIT
START ;***Start queuing here.
+1 DO @PSGSS
+2 ;***Queue to the printer.
+3 IF $DATA(PSGIO)
Begin DoDot:1
+4 SET XDESC="Extra Unit Dose Dispensed (Print)"
+5 SET XSAVE="^TMP($J,;PSGWGNM;PSGTMALL;PSGTM;PSGSDT;PSGEDT;PSGSS;PSGIODOC"
+6 SET XTRTN="^PSGEUDP"
+7 DO SETPRTQ^PSJMUTL(XDESC,XSAVE,XTRTN)
End DoDot:1
GOTO EXIT
+8 DO ^PSGEUDP
+9 QUIT
+10 ;
P ;***Select by Patient
+1 SET PPN=""
FOR
SET PPN=$ORDER(PSGPAT(PPN))
if PPN=""
QUIT
SET PSGP=PSGPAT(PPN)
SET PSJACNWP=""
KILL PSJPPID,PSJPRB
DO ^PSJAC
DO LOOP
+2 QUIT
+3 ;
C ;***Select by CLINIC
+1 NEW DT,CLIN
+2 SET TM="ZZ"
SET PSJACNWP=""
+3 SET DT=PSGSDT
FOR
SET DT=$ORDER(^PS(55,"AUDC",DT))
if DT>PSGEDT!(DT="")
QUIT
SET CLIN=0
FOR
SET CLIN=$ORDER(^PS(55,"AUDC",DT,CLIN))
if 'CLIN
QUIT
Begin DoDot:1
+4 SET PSGP=0
FOR
SET PSGP=$ORDER(^PS(55,"AUDC",DT,CLIN,PSGP))
if 'PSGP
QUIT
DO ^PSJAC
SET PPN=PSGP(0)
DO LOOP
End DoDot:1
+5 QUIT
G ;***Select by WARD GROUP
+1 DO WARDGP
+2 QUIT
W ;***Select by Ward
+1 DO WARD
+2 QUIT
WARDGP ;*** Find wards within a ward group
+1 SET PSGWD=""
SET TM="ZZ"
FOR
SET PSGWD=$ORDER(^PS(57.5,"AC",PSGWG,PSGWD))
if 'PSGWD
QUIT
IF $DATA(^DIC(42,+PSGWD,0))
SET PSGWN=$PIECE(^(0),U)
DO WARD
+2 QUIT
+3 ;
WARD ;*** Go through each patient within a given WARD
+1 ;*** Var used in PSJAC. Set to null to skip WP^PSJAC
+2 SET PSJACNWP=""
+3 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGWN,PSGP))
if 'PSGP
QUIT
DO ^PSJAC
SET PPN=PSGP(0)
if PSGSS="W"
DO TEAM
if PSGSS="G"
DO LOOP
+4 QUIT
TEAM ;*** Look up selected team. PSGTMALL= All teams were selected.
+1 SET TM=""
+2 IF PSGTMALL
DO ALLTM
DO LOOP
QUIT
+3 IF 'PSGTM
SET TM="ZZ"
DO LOOP
QUIT
+4 DO ALLTM
if $DATA(PSGTM(TM))
DO LOOP
+5 QUIT
+6 ;
ALLTM ;*** Get UNIT DOSE information from ^PS(55
+1 ;
+2 SET TM="ZZ"
+3 SET TM=$SELECT(PSJPRB="":0,1:+$ORDER(^PS(57.7,"AWRT",PSGWD,PSJPRB,0)))
SET TM=$SELECT('TM:"ZZ",'$DATA(^PS(57.7,PSGWD,1,TM,0)):TM,$PIECE(^(0),U)]"":$PIECE(^(0),U),1:TM)
+4 QUIT
+5 ;
LOOP ;***Loop thru ^PS(55 on the Dispense log multiple.
+1 FOR PSGORD=0:0
SET PSGORD=$ORDER(^PS(55,+PSGP,5,PSGORD))
if 'PSGORD
QUIT
Begin DoDot:1
+2 SET PSGDT=PSGSDT-.000001
+3 FOR
SET PSGDT=$ORDER(^PS(55,+PSGP,5,+PSGORD,11,"B",PSGDT))
if 'PSGDT!(PSGEDT<PSGDT)
QUIT
Begin DoDot:2
+4 FOR NO=0:0
SET NO=$ORDER(^PS(55,+PSGP,5,+PSGORD,11,"B",PSGDT,NO))
if 'NO
QUIT
SET ND=^PS(55,+PSGP,5,+PSGORD,11,NO,0)
Begin DoDot:3
+5 IF $PIECE(ND,U,5)=3
SET DRG=$$ENDDN^PSGMI($PIECE(ND,U,2))
SET AMT=$PIECE(ND,U,3)
SET WHO=$PIECE(ND,U,6)
DO @($SELECT(PSGSS="P":"TMPPT",1:"TMPWG"))
End DoDot:3
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
TMPWG ;***Set ^TMP global for selected by Ward/Ward Group.
+1 SET ^TMP($JOB,PSGWN,TM,DRG,$EXTRACT(PPN,1,10)_"^"_+PSGP,PSGDT)=AMT_U_WHO_U_PSJPBID
+2 QUIT
+3 ;
TMPPT ;***Set ^TMP global for selected by patient.
+1 SET ^TMP($JOB,$EXTRACT(PPN,1,10)_"^"_+PSGP,DRG,PSGDT)=AMT_U_WHO_U_PSJPPID_U_PSJPRB_U_PSJPWDN
+2 QUIT
