PSJPDRIP ;BIR/MV-MAIN DRIVER PADE INVENTORY REPORT ;18 JUN 96 / 2:58 PM
;;5.0;INPATIENT MEDICATIONS;**317**;16 DEC 97;Build 130
;
; Reference to ^%ZISC is supported by DBIA 10089.
; Reference to ^XLFDT is supported by DBIA 10103.
; Reference to ^DG(40.8 is supported by DBIA 728.
; Reference to ^PSDRUG is supported by DBIA 2192.
; Reference to ^VA(200 is supported by DBIA 10060.
Q
;
EN(PSJINP) ; Write PADE Inventory Report
; Required : ^TMP("PSJPDRIN",$J global array containing report data in delimited format.
; PSJINP array
; PSJINP("PADEV") = PADE device(s) (pointer to PADE DISPENSING DEVICE #58.63) selected by user
; PSJINP("PSDRG") = Drug(s) (pointer to DRUG #50) selected by user
; PSJINP("PSJCSUB") = CS Federal Schedule(s) selected by user
; PSJINP("PSJDEV",CABIEN) = Pointer to PADE DISPENSING DEVICE (#58.63) file
; PSJINP("PSJDELM") = (D)elimited or formatted (R)eport, selected by user
; PSJINP("PSJDIV") = Division (pointer to MEDICAL CENTER DIVISION #40.8) selected by user
; PSJINP("PSJPSYS" = PADE INVENTORY SYSTEM (#58.601) selected by user
; PSJINP("PSJSUM" = (S)ummary or (D)etail report, selected by user
;
N PSJDELIM,PSJQUIT,PSJIOSL,PSPGTOT,LNCNT,PSJPTOT,DTOUT,DUOUT,DA,DIC,X,Y,DIR,DR
S PSJIOSL=$S($G(IOSL):IOSL-5,1:20)
S PSJDELIM=$G(PSJINP("PSJDELM"))
U IO
I PSJDELIM="D" D DELIM(.PSJINP)
I PSJDELIM="R" D FORMAT(.PSJINP)
Q
;
DELIM(PSJINP) ; Output delimited report
N PSJPGTOT,PSJPCNT
S PSJPTOT=1,PSJPCNT=1
D RHEAD^PSJPDRIP(.PSJINP,PSJPTOT,PSJPCNT)
S LNCNT=0 F S LNCNT=$O(^TMP("PSJPDRIN",$J,LNCNT)) Q:'LNCNT!$G(PSJQUIT) D
.W !,^TMP("PSJPDRIN",$J,LNCNT)
D ^%ZISC
D EXIT
Q
;
FORMAT(PSJINP) ; Output formatted report
N CABNAME,PSJPGTOT,PSJPCNT
S PSJPCNT=1,PSJPGTOT=$$PGTOT()
D RHEAD^PSJPDRIP(.PSJINP,PSJPCNT,PSJPGTOT)
S LNCNT=0 F S LNCNT=$O(^TMP("PSJPDRIN",$J,LNCNT)) Q:'LNCNT!$G(PSJQUIT) D
.N LINE,PSCOL
.S LINE=$G(^TMP("PSJPDRIN",$J,LNCNT))
.D SETCOLS(.PSJINP,.PSCOL)
.I $G(PSJINP("PSJSUM"))="S" I $L($P(LINE,"^"))>1 S CABNAME=$P(LINE,"^")
.W !?PSCOL(1),$P(LINE,"^"),?PSCOL(2),$P(LINE,"^",2),?PSCOL(3),$P(LINE,"^",3),?PSCOL(4),$P(LINE,"^",4),?PSCOL(5),$P(LINE,"^",5),?PSCOL(6),$P(LINE,"^",6)
.N CABCONT
.Q:($Y<(PSJIOSL))
.I ($G(PSJINP("PSJSUM"))="S") I $G(CABNAME)]"" I ($P(LINE,"^")]"")!($P(LINE,"^",2)]"") D
..N NXT S NXT=+$O(^TMP("PSJPDRIN",$J,LNCNT))
..S NXT=$P($G(^TMP("PSJPDRIN",$J,NXT)),"^") S:NXT="" CABCONT=CABNAME_"(cont) "
.D CONT(.PSJPCNT,.PSJQUIT,LNCNT)
.Q:$G(PSJQUIT)
.D RHEAD(.PSJINP,PSJPCNT,PSJPGTOT,$G(CABCONT))
I '$G(PSJQUIT) D CONT(.PSJPCNT,.PSJQUIT,$O(^TMP("PSJPDRIN",$J,9999999),-1)+1)
D ^%ZISC
D EXIT
Q
;
RHEAD(PSJINP,PSJPCNT,PSJPGTOT,CABCONT) ; Report Header
N PSPGCNT,PSJDIV,CSCHED,PSJTMP,PADECAB,PADEDRG,PSJII,PSJCABS,PSJSUM
S PSJPGTOT=$S($G(PSJPGTOT):+$G(PSJPGTOT),1:1)
S PSJDIV=$G(PSJINP("PSJDIV"))
S PSPGTOT=$G(PSJINP("PSPGTOT")),PSPGCNT=1
S PSJSUM=$G(PSJINP("PSJSUM"))
W @IOF
W !,"Run Date: "_$P($TR($$FMTE^XLFDT($$NOW^XLFDT,2),"@"," "),":",1,2)
W ?27,"PADE On Hand Amounts Report ",$S(($G(PSJSUM)="S"):"(Summary)",1:"(Detail)")
W ?66,"Page ",PSJPCNT," of ",PSJPGTOT
W !,"Run By: ",$P($G(^VA(200,+$G(DUZ),0)),"^")
W ?35,"Division: ",$E($$DIVSTR^PSJPDRTR(.PSJINP),1,44)
S CSCHED=$$CSCHED(.PSJINP)
W !,"CS/Non-CS: ",$S($G(PSJINP("PSJCSUB"))="N":"N",1:$G(CSCHED))
S PSJCABS=$$CABSTR(.PSJINP)
W !,"PADE"_$S(PSJCABS[",":"s: ",1:": "),PSJCABS
S PADEDRG=$$DRGSTR(.PSJINP)
W !,"ITEM"_$S(PADEDRG[",":"(s): ",1:": "),PADEDRG
D:($G(PSJINP("PSJSUM"))="S") SUMHEAD(.PSJINP,$G(CABCONT))
D:($G(PSJINP("PSJSUM"))="D") DETHEAD(.PSJINP)
Q
;
SUMHEAD(PSJINP,CABCONT) ; Summary specific header
N DASHES,BLANK,PSJCOL
I $G(PSJINP("PSJDELM"))="D" D Q
.W !,"PADE^ITEM^UNIT^QTY"
D SETCOLS(.PSJINP,.PSJCOL)
S $P(DASHES,"-",80)="-"
S $P(BLANK," ",80)=""
W !,DASHES
W !?2,"ITEM",?PSJCOL(3)-1,"UNIT",?PSJCOL(4)+1,"QTY"
W !,DASHES
W !,$S($G(CABCONT)]"":CABCONT,1:BLANK)
Q
;
DETHEAD(PSJINP) ; Detail specific header
N DASHES,PSJCOL
I $G(PSJINP("PSJDELM"))="D" D Q
.W !,"ITEM^UNIT^QTY^PADE^ITEM LOCATION"
D SETCOLS(.PSJINP,.PSJCOL)
S $P(DASHES,"-",80)="-"
W !,DASHES
W !,"ITEM",?PSJCOL(2),"UNIT",?PSJCOL(3)," QTY",?PSJCOL(4),"PADE",?PSJCOL(5),"ITEM LOCATION"
W !,DASHES
Q
;
EXIT ; Clean up.
K ^TMP("PSJPDRIN",$J)
Q
;
POCKDRG(PSJPSYS,PSJCAB,DRUG,DRWPCK) ; Get Drawer.Pocket location of DRUG in PSJCAB cabinet
;
N CABIEN,DRGIEN,DRWIEN,DRWNAM,PCKIEN,PCKNAM,ND,LOCNAM,PSJII
Q:'$G(PSJPSYS)!'$G(PSJCAB)!'$G(PSJCAB)
S CABIEN=$$FIND1^DIC(58.6011,","_PSJPSYS_",","MXQ",+$G(PSJCAB),,,"ERR")
S DRWIEN=0 F S DRWIEN=$O(^PS(58.601,PSJPSYS,"DEVICE",CABIEN,"DRAWER",DRWIEN)) Q:'DRWIEN S DRWNAM=$P(^(DRWIEN,0),"^") D
.S PCKIEN=0 F S PCKIEN=$O(^PS(58.601,PSJPSYS,"DEVICE",CABIEN,"DRAWER",DRWIEN,"SUB",PCKIEN)) Q:'PCKIEN S ND=^(PCKIEN,0) I $P(ND,"^",5)=DRUG D
..N LOCNAM,SUBID
..S SUBID=$P(ND,"^",4) S:SUBID["~~" SUBID=$P(SUBID,"~~") S:SUBID="" SUBID="N/A"
..S PCKNAM=DRWNAM_"_"_SUBID_"_"_$P(ND,"^",3)
..F PSJII=1:1:$L(PCKNAM,"_") D
...N TMPLOC S TMPLOC=$P(PCKNAM,"_",PSJII)
...S TMPLOC=$S(TMPLOC="~~":"N/A",1:TMPLOC)
...S LOCNAM=$G(LOCNAM)_TMPLOC_"_"
..S:$E(LOCNAM,$L(LOCNAM))="_" LOCNAM=$E(LOCNAM,1,$L(LOCNAM)-1)
..S DRWPCK(DRUG,LOCNAM)=$P(ND,"^",2)
Q
;
CONT(PGCNT,PSJQUIT,TMPLN) ; Press return to continue
N DIR
I ($E($G(IOST))="C") W ! D Q:$G(PSJQUIT)
.I '$O(^TMP("PSJPDRIN",$J,TMPLN)) S DIR("A")="End of Report. Press Return to continue" S PSJQUIT=1
.S DIR(0)="E"
.D ^DIR K DIR
.I $G(DTOUT)!$G(DUOUT) S PSJQUIT=1
.W @IOF
S PGCNT=$G(PGCNT)+1
Q
;
PGTOT() ; Return calculated number of pages for this report
N PGTOT,LN,PSJSL,INT,HDRPAD,HDR,HDRWRAP,SCHWRAP,PADEWRAP,DRGWRAP,PSJAVAIL,HDRTOP
S PSJIOSL=$S($G(PSJIOSL):PSJIOSL,1:20)
S LN=$O(^TMP("PSJPDRIN",$J,999999999),-1)
S SCHWRAP=($L($$CSCHED(.PSJINP))+10)/80
S:SCHWRAP#1 SCHWRAP=(SCHWRAP\1)+1
S PADEWRAP=($L($$CABSTR(.PSJINP))+6)/80
S:PADEWRAP#1 PADEWRAP=(PADEWRAP\1)+1
S DRGWRAP=($L($$DRGSTR(.PSJINP))+7)/80
S:DRGWRAP#1 DRGWRAP=(DRGWRAP\1)+1
S HDRWRAP=SCHWRAP+PADEWRAP+DRGWRAP
S HDRTOP=$S($G(PSJINP("PSJSUM"))="D":5,1:6)
S HDRPAD=(HDRTOP+HDRWRAP)
; How many lines are availabe for actual report data, after header and footer are taken into account?
; If less than five lines per page for report data, set to 5 (longer page length needed)
S PSJAVAIL=PSJIOSL-HDRPAD
; Determine how many pages will be needed to print the total lines in ^TMP("PSJPDRIN",
; using the available area (PSJAVAIL) on each page
S PGTOT=LN\PSJAVAIL
;S PSJLASTP=LN#PSJAVAIL
S:LN#PSJAVAIL PGTOT=PGTOT+1
;
Q PGTOT
;
CSCHED(PSJINP) ; Return string of CS Federal Schedules from array PSJINP("PSJCSUB",SCHEDULE)
N CSCHED N PSJTMP
S CSCHED=$G(PSJINP("PSJCSUB")) I '(CSCHED="N") S CSCHED="CS (" D
.I $G(PSJINP("PSJCSUB"))["ALL" S CSCHED=PSJINP("PSJCSUB") Q
.S PSJTMP="" F S PSJTMP=$O(PSJINP("PSJCSUB",PSJTMP)) Q:PSJTMP="" S CSCHED=CSCHED_PSJTMP_","
.I $E(CSCHED,$L(CSCHED))="," S CSCHED=$E(CSCHED,1,$L(CSCHED)-1)_")"
Q CSCHED
;
CABSTR(PSJINP) ; Return string of PADE cabinets from array PSJINP("PADEV",CABINET)
N CABSTR N PSJTMP,PSJII,PSJDONE
S PSJTMP=0 F PSJII=0:1 S PSJTMP=$O(PSJINP("PADEV",PSJTMP)) Q:'PSJTMP!$G(PSJDONE) D
.I $G(PSJINP("PADEV"))="ALL" S CABSTR="ALL",PSJDONE=1 Q
.I $L($G(CABSTR))+$L($P($G(^PS(58.63,+PSJTMP,0)),"^"))>140 S CABSTR=CABSTR_" >> more..." S PSJDONE=1 Q
.S CABSTR=$S(PSJII:$G(CABSTR)_",",1:"")_$P($G(^PS(58.63,+PSJTMP,0)),"^")
Q CABSTR
;
DRGSTR(PSJINP) ; Return string of PADE drugs selected by user from PSJINP("PSDRG",DRUG IEN)
N PADEDRG,PSJTMP,PSJII,PSJDONE
S PADEDRG="",PSJTMP="" F PSJII=0:1 S PSJTMP=$O(PSJINP("PSDRG",PSJTMP)) Q:'PSJTMP!$G(PSJDONE) D
.I $G(PSJINP("PSDRG"))="ALL" S PADEDRG="ALL",PSJDONE=1 Q
.S PADEDRG=$S(PSJII:(PADEDRG_","),1:"")_$P($G(^PSDRUG(+PSJTMP,0)),"^")
.I $L(PADEDRG)>187 S PADEDRG=PADEDRG_" > more..." S PSJDONE=1 Q
S:$E(PADEDRG,$L(PADEDRG)) PADEDRG=$E(PADEDRG,1,$L(PADEDRG)=1)
Q PADEDRG
;
SETCOLS(PSJINP,COL) ; Set column widths
I $G(PSJINP("PSJSUM"))="S" D
.S COL(1)=0,COL(2)=2,COL(3)=50,COL(4)=60,COL(5)=68,COL(6)=74
I $G(PSJINP("PSJSUM"))="D" D
.S COL(1)=0,COL(2)=38,COL(3)=48,COL(4)=53,COL(5)=64,COL(6)=75
Q
;
TRANSTR(PSJINP) ; Return string of transaction types selected
N TRANS,TMP,II,PATFLG
S PATFLG=$$PTTRFLG^PSJPDRU1(.PSJINP)
S TRANS=""
I $G(PSJINP("PSJTRANS"))="ALL"&(PATFLG=1) Q "ALL"
I $G(PSJINP("PSJTRANS"))="ALL"&(PATFLG=2) Q "ALL PATIENT TRANSACTIONS"
I $G(PSJINP("PSJTRANS"))="ALL"&'PATFLG Q "ALL NON-PATIENT TRANSACTIONS"
S TMP="" F II=0:1 S TMP=$O(PSJINP("PSJTRANS",TMP)) Q:TMP="" S TRANS=$S(II:TRANS_","_PSJINP("PSJTRANS",TMP),1:PSJINP("PSJTRANS",TMP))
Q TRANS
;
CABST(PSJPSYS,PSJPADE) ; Return PADE Status : (I)=Inactive or null
N STATUS,PADIEN
Q:'$G(PSJPSYS) ""
Q:$G(PSJPADE)="" ""
S PADIEN=$$FIND1^DIC(58.63,,,PSJPADE)
Q:'PADIEN ""
S STATUS=$P($G(^PS(58.63,+PADIEN,0)),"^",4)
S STATUS=$S(STATUS="I":"(I)",1:"")
Q STATUS
;
XALL(IN) ; Convert partial ^ALL to ALL
N OUT
S OUT=IN
I ($E(IN)'="^")!(IN="^") Q OUT
S OUT=$$ENLU^PSGMI(OUT)
I $E(OUT,1,$L(OUT))=$E("^ALL",1,$L(OUT)) D
.S OUT="ALL"
.K DUOUT,DTOUT
Q OUT
;
CONT2(PGCNT,PSJQUIT,PSJEND) ; Press return to continue
N DIR
I ($E($G(IOST))="C") W ! D Q:$G(PSJQUIT)
.I $G(PSJEND) S DIR("A")="End of Report. Press Return to continue" S PSJQUIT=1
.S:'$D(DIR("A")) DIR("A")="Press Return to continue or '^' to exit"
.S DIR(0)="FO"
.D ^DIR K DIR
.I $G(DTOUT)!$G(DUOUT) S PSJQUIT=1
.W @IOF
S PGCNT=$G(PGCNT)+1
Q
;
CNVTYP(INTYP,PSJOUT) ; Convert Transaction Types to external format from raw HL7
N TTCNT,PSJOUTE K PSJOUT
S TTCNT=0 F S TTCNT=$O(INTYP(TTCNT)) Q:'TTCNT D
.N TTNAME,TTCODE S TTNAME=INTYP(TTCNT)
.S TTCODE=$$EXTT^PSJPDRUT(TTNAME)
.I TTCODE]"" S PSJOUT(TTCODE)=TTNAME
.Q
.I $E(INTYP(TTCNT))="D" S PSJOUT("V")="VEND",PSJOUT("I")="ISSUE" Q
.I $E(INTYP(TTCNT))="L" S PSJOUT("L")="LOAD" Q
.I $E(INTYP(TTCNT))="F" S PSJOUT("F")="FILL" Q
.I $E(INTYP(TTCNT))="U" S PSJOUT("U")="UNLOAD" Q
.I $E(INTYP(TTCNT))="B" S PSJOUT("B")="EMPTY BIN" Q
.I $E(INTYP(TTCNT))="C" S PSJOUT("C")="COUNT" Q
.I $E(INTYP(TTCNT))="R" S PSJOUT("R")="RETURN" Q
.I $E(INTYP(TTCNT))="W" S PSJOUT("W")="WASTE" Q
.I $E(INTYP(TTCNT))="E" S PSJOUT("E")="EXPIRED" Q
.I INTYP(TTCNT)="Destock" S PSJOUT("D")="DESTOCK" Q
Q
;
ALLSCHED(PSJCSUB,SCHLST) ; Return all CS Federal Schedules in PSJCSUB(SCHEDULE)
N SCHED,SCNT
F SCNT=1:1:$L(SCHLST,";") S SCHED=$P(SCHLST,";",SCNT),PSJCSUB($P(SCHED,":"))=$P(SCHED,":",2)
Q
;
DIV(PSJDIV,PSJSTOP) ; Get Division
N DIC,X,Y,PSJDONE,PSDIVLST,PSJDIC
S DIC("S")="I $D(^PS(58.63,""D"",+Y))"
S PSJSTOP=0
D LIST^DIC(40.8,,,"P",,,,,DIC("S"),,"PSDIVLST")
S PSJDIC=0 F S PSJDIC=$O(PSDIVLST("DILIST",PSJDIC)) Q:'PSJDIC D
.S PSDIVLST=+$G(PSDIVLST("DILIST",PSJDIC,0))
.S PSDIVLST("PSJDIV",PSDIVLST)=""
S PSJDIV="" K PSJDONE,PSJDIV
S DIC("S")="I $D(^PS(58.63,""D"",+Y))"
D DIV^PSJPDRUT(.PSJDIV,.PSJSTOP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDRIP 11250 printed Dec 13, 2024@02:08:47 Page 2
PSJPDRIP ;BIR/MV-MAIN DRIVER PADE INVENTORY REPORT ;18 JUN 96 / 2:58 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**317**;16 DEC 97;Build 130
+2 ;
+3 ; Reference to ^%ZISC is supported by DBIA 10089.
+4 ; Reference to ^XLFDT is supported by DBIA 10103.
+5 ; Reference to ^DG(40.8 is supported by DBIA 728.
+6 ; Reference to ^PSDRUG is supported by DBIA 2192.
+7 ; Reference to ^VA(200 is supported by DBIA 10060.
+8 QUIT
+9 ;
EN(PSJINP) ; Write PADE Inventory Report
+1 ; Required : ^TMP("PSJPDRIN",$J global array containing report data in delimited format.
+2 ; PSJINP array
+3 ; PSJINP("PADEV") = PADE device(s) (pointer to PADE DISPENSING DEVICE #58.63) selected by user
+4 ; PSJINP("PSDRG") = Drug(s) (pointer to DRUG #50) selected by user
+5 ; PSJINP("PSJCSUB") = CS Federal Schedule(s) selected by user
+6 ; PSJINP("PSJDEV",CABIEN) = Pointer to PADE DISPENSING DEVICE (#58.63) file
+7 ; PSJINP("PSJDELM") = (D)elimited or formatted (R)eport, selected by user
+8 ; PSJINP("PSJDIV") = Division (pointer to MEDICAL CENTER DIVISION #40.8) selected by user
+9 ; PSJINP("PSJPSYS" = PADE INVENTORY SYSTEM (#58.601) selected by user
+10 ; PSJINP("PSJSUM" = (S)ummary or (D)etail report, selected by user
+11 ;
+12 NEW PSJDELIM,PSJQUIT,PSJIOSL,PSPGTOT,LNCNT,PSJPTOT,DTOUT,DUOUT,DA,DIC,X,Y,DIR,DR
+13 SET PSJIOSL=$SELECT($GET(IOSL):IOSL-5,1:20)
+14 SET PSJDELIM=$GET(PSJINP("PSJDELM"))
+15 USE IO
+16 IF PSJDELIM="D"
DO DELIM(.PSJINP)
+17 IF PSJDELIM="R"
DO FORMAT(.PSJINP)
+18 QUIT
+19 ;
DELIM(PSJINP) ; Output delimited report
+1 NEW PSJPGTOT,PSJPCNT
+2 SET PSJPTOT=1
SET PSJPCNT=1
+3 DO RHEAD^PSJPDRIP(.PSJINP,PSJPTOT,PSJPCNT)
+4 SET LNCNT=0
FOR
SET LNCNT=$ORDER(^TMP("PSJPDRIN",$JOB,LNCNT))
if 'LNCNT!$GET(PSJQUIT)
QUIT
Begin DoDot:1
+5 WRITE !,^TMP("PSJPDRIN",$JOB,LNCNT)
End DoDot:1
+6 DO ^%ZISC
+7 DO EXIT
+8 QUIT
+9 ;
FORMAT(PSJINP) ; Output formatted report
+1 NEW CABNAME,PSJPGTOT,PSJPCNT
+2 SET PSJPCNT=1
SET PSJPGTOT=$$PGTOT()
+3 DO RHEAD^PSJPDRIP(.PSJINP,PSJPCNT,PSJPGTOT)
+4 SET LNCNT=0
FOR
SET LNCNT=$ORDER(^TMP("PSJPDRIN",$JOB,LNCNT))
if 'LNCNT!$GET(PSJQUIT)
QUIT
Begin DoDot:1
+5 NEW LINE,PSCOL
+6 SET LINE=$GET(^TMP("PSJPDRIN",$JOB,LNCNT))
+7 DO SETCOLS(.PSJINP,.PSCOL)
+8 IF $GET(PSJINP("PSJSUM"))="S"
IF $LENGTH($PIECE(LINE,"^"))>1
SET CABNAME=$PIECE(LINE,"^")
+9 WRITE !?PSCOL(1),$PIECE(LINE,"^"),?PSCOL(2),$PIECE(LINE,"^",2),?PSCOL(3),$PIECE(LINE,"^",3),?PSCOL(4),$PIECE(LINE,"^",4),?PSCOL(5),$PIECE(LINE,"^",5),?PSCOL(6),$PIECE(LINE,"^",6)
+10 NEW CABCONT
+11 if ($Y<(PSJIOSL))
QUIT
+12 IF ($GET(PSJINP("PSJSUM"))="S")
IF $GET(CABNAME)]""
IF ($PIECE(LINE,"^")]"")!($PIECE(LINE,"^",2)]"")
Begin DoDot:2
+13 NEW NXT
SET NXT=+$ORDER(^TMP("PSJPDRIN",$JOB,LNCNT))
+14 SET NXT=$PIECE($GET(^TMP("PSJPDRIN",$JOB,NXT)),"^")
if NXT=""
SET CABCONT=CABNAME_"(cont) "
End DoDot:2
+15 DO CONT(.PSJPCNT,.PSJQUIT,LNCNT)
+16 if $GET(PSJQUIT)
QUIT
+17 DO RHEAD(.PSJINP,PSJPCNT,PSJPGTOT,$GET(CABCONT))
End DoDot:1
+18 IF '$GET(PSJQUIT)
DO CONT(.PSJPCNT,.PSJQUIT,$ORDER(^TMP("PSJPDRIN",$JOB,9999999),-1)+1)
+19 DO ^%ZISC
+20 DO EXIT
+21 QUIT
+22 ;
RHEAD(PSJINP,PSJPCNT,PSJPGTOT,CABCONT) ; Report Header
+1 NEW PSPGCNT,PSJDIV,CSCHED,PSJTMP,PADECAB,PADEDRG,PSJII,PSJCABS,PSJSUM
+2 SET PSJPGTOT=$SELECT($GET(PSJPGTOT):+$GET(PSJPGTOT),1:1)
+3 SET PSJDIV=$GET(PSJINP("PSJDIV"))
+4 SET PSPGTOT=$GET(PSJINP("PSPGTOT"))
SET PSPGCNT=1
+5 SET PSJSUM=$GET(PSJINP("PSJSUM"))
+6 WRITE @IOF
+7 WRITE !,"Run Date: "_$PIECE($TRANSLATE($$FMTE^XLFDT($$NOW^XLFDT,2),"@"," "),":",1,2)
+8 WRITE ?27,"PADE On Hand Amounts Report ",$SELECT(($GET(PSJSUM)="S"):"(Summary)",1:"(Detail)")
+9 WRITE ?66,"Page ",PSJPCNT," of ",PSJPGTOT
+10 WRITE !,"Run By: ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),"^")
+11 WRITE ?35,"Division: ",$EXTRACT($$DIVSTR^PSJPDRTR(.PSJINP),1,44)
+12 SET CSCHED=$$CSCHED(.PSJINP)
+13 WRITE !,"CS/Non-CS: ",$SELECT($GET(PSJINP("PSJCSUB"))="N":"N",1:$GET(CSCHED))
+14 SET PSJCABS=$$CABSTR(.PSJINP)
+15 WRITE !,"PADE"_$SELECT(PSJCABS[",":"s: ",1:": "),PSJCABS
+16 SET PADEDRG=$$DRGSTR(.PSJINP)
+17 WRITE !,"ITEM"_$SELECT(PADEDRG[",":"(s): ",1:": "),PADEDRG
+18 if ($GET(PSJINP("PSJSUM"))="S")
DO SUMHEAD(.PSJINP,$GET(CABCONT))
+19 if ($GET(PSJINP("PSJSUM"))="D")
DO DETHEAD(.PSJINP)
+20 QUIT
+21 ;
SUMHEAD(PSJINP,CABCONT) ; Summary specific header
+1 NEW DASHES,BLANK,PSJCOL
+2 IF $GET(PSJINP("PSJDELM"))="D"
Begin DoDot:1
+3 WRITE !,"PADE^ITEM^UNIT^QTY"
End DoDot:1
QUIT
+4 DO SETCOLS(.PSJINP,.PSJCOL)
+5 SET $PIECE(DASHES,"-",80)="-"
+6 SET $PIECE(BLANK," ",80)=""
+7 WRITE !,DASHES
+8 WRITE !?2,"ITEM",?PSJCOL(3)-1,"UNIT",?PSJCOL(4)+1,"QTY"
+9 WRITE !,DASHES
+10 WRITE !,$SELECT($GET(CABCONT)]"":CABCONT,1:BLANK)
+11 QUIT
+12 ;
DETHEAD(PSJINP) ; Detail specific header
+1 NEW DASHES,PSJCOL
+2 IF $GET(PSJINP("PSJDELM"))="D"
Begin DoDot:1
+3 WRITE !,"ITEM^UNIT^QTY^PADE^ITEM LOCATION"
End DoDot:1
QUIT
+4 DO SETCOLS(.PSJINP,.PSJCOL)
+5 SET $PIECE(DASHES,"-",80)="-"
+6 WRITE !,DASHES
+7 WRITE !,"ITEM",?PSJCOL(2),"UNIT",?PSJCOL(3)," QTY",?PSJCOL(4),"PADE",?PSJCOL(5),"ITEM LOCATION"
+8 WRITE !,DASHES
+9 QUIT
+10 ;
EXIT ; Clean up.
+1 KILL ^TMP("PSJPDRIN",$JOB)
+2 QUIT
+3 ;
POCKDRG(PSJPSYS,PSJCAB,DRUG,DRWPCK) ; Get Drawer.Pocket location of DRUG in PSJCAB cabinet
+1 ;
+2 NEW CABIEN,DRGIEN,DRWIEN,DRWNAM,PCKIEN,PCKNAM,ND,LOCNAM,PSJII
+3 if '$GET(PSJPSYS)!'$GET(PSJCAB)!'$GET(PSJCAB)
QUIT
+4 SET CABIEN=$$FIND1^DIC(58.6011,","_PSJPSYS_",","MXQ",+$GET(PSJCAB),,,"ERR")
+5 SET DRWIEN=0
FOR
SET DRWIEN=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",CABIEN,"DRAWER",DRWIEN))
if 'DRWIEN
QUIT
SET DRWNAM=$PIECE(^(DRWIEN,0),"^")
Begin DoDot:1
+6 SET PCKIEN=0
FOR
SET PCKIEN=$ORDER(^PS(58.601,PSJPSYS,"DEVICE",CABIEN,"DRAWER",DRWIEN,"SUB",PCKIEN))
if 'PCKIEN
QUIT
SET ND=^(PCKIEN,0)
IF $PIECE(ND,"^",5)=DRUG
Begin DoDot:2
+7 NEW LOCNAM,SUBID
+8 SET SUBID=$PIECE(ND,"^",4)
if SUBID["~~"
SET SUBID=$PIECE(SUBID,"~~")
if SUBID=""
SET SUBID="N/A"
+9 SET PCKNAM=DRWNAM_"_"_SUBID_"_"_$PIECE(ND,"^",3)
+10 FOR PSJII=1:1:$LENGTH(PCKNAM,"_")
Begin DoDot:3
+11 NEW TMPLOC
SET TMPLOC=$PIECE(PCKNAM,"_",PSJII)
+12 SET TMPLOC=$SELECT(TMPLOC="~~":"N/A",1:TMPLOC)
+13 SET LOCNAM=$GET(LOCNAM)_TMPLOC_"_"
End DoDot:3
+14 if $EXTRACT(LOCNAM,$LENGTH(LOCNAM))="_"
SET LOCNAM=$EXTRACT(LOCNAM,1,$LENGTH(LOCNAM)-1)
+15 SET DRWPCK(DRUG,LOCNAM)=$PIECE(ND,"^",2)
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
CONT(PGCNT,PSJQUIT,TMPLN) ; Press return to continue
+1 NEW DIR
+2 IF ($EXTRACT($GET(IOST))="C")
WRITE !
Begin DoDot:1
+3 IF '$ORDER(^TMP("PSJPDRIN",$JOB,TMPLN))
SET DIR("A")="End of Report. Press Return to continue"
SET PSJQUIT=1
+4 SET DIR(0)="E"
+5 DO ^DIR
KILL DIR
+6 IF $GET(DTOUT)!$GET(DUOUT)
SET PSJQUIT=1
+7 WRITE @IOF
End DoDot:1
if $GET(PSJQUIT)
QUIT
+8 SET PGCNT=$GET(PGCNT)+1
+9 QUIT
+10 ;
PGTOT() ; Return calculated number of pages for this report
+1 NEW PGTOT,LN,PSJSL,INT,HDRPAD,HDR,HDRWRAP,SCHWRAP,PADEWRAP,DRGWRAP,PSJAVAIL,HDRTOP
+2 SET PSJIOSL=$SELECT($GET(PSJIOSL):PSJIOSL,1:20)
+3 SET LN=$ORDER(^TMP("PSJPDRIN",$JOB,999999999),-1)
+4 SET SCHWRAP=($LENGTH($$CSCHED(.PSJINP))+10)/80
+5 if SCHWRAP#1
SET SCHWRAP=(SCHWRAP\1)+1
+6 SET PADEWRAP=($LENGTH($$CABSTR(.PSJINP))+6)/80
+7 if PADEWRAP#1
SET PADEWRAP=(PADEWRAP\1)+1
+8 SET DRGWRAP=($LENGTH($$DRGSTR(.PSJINP))+7)/80
+9 if DRGWRAP#1
SET DRGWRAP=(DRGWRAP\1)+1
+10 SET HDRWRAP=SCHWRAP+PADEWRAP+DRGWRAP
+11 SET HDRTOP=$SELECT($GET(PSJINP("PSJSUM"))="D":5,1:6)
+12 SET HDRPAD=(HDRTOP+HDRWRAP)
+13 ; How many lines are availabe for actual report data, after header and footer are taken into account?
+14 ; If less than five lines per page for report data, set to 5 (longer page length needed)
+15 SET PSJAVAIL=PSJIOSL-HDRPAD
+16 ; Determine how many pages will be needed to print the total lines in ^TMP("PSJPDRIN",
+17 ; using the available area (PSJAVAIL) on each page
+18 SET PGTOT=LN\PSJAVAIL
+19 ;S PSJLASTP=LN#PSJAVAIL
+20 if LN#PSJAVAIL
SET PGTOT=PGTOT+1
+21 ;
+22 QUIT PGTOT
+23 ;
CSCHED(PSJINP) ; Return string of CS Federal Schedules from array PSJINP("PSJCSUB",SCHEDULE)
+1 NEW CSCHED
NEW PSJTMP
+2 SET CSCHED=$GET(PSJINP("PSJCSUB"))
IF '(CSCHED="N")
SET CSCHED="CS ("
Begin DoDot:1
+3 IF $GET(PSJINP("PSJCSUB"))["ALL"
SET CSCHED=PSJINP("PSJCSUB")
QUIT
+4 SET PSJTMP=""
FOR
SET PSJTMP=$ORDER(PSJINP("PSJCSUB",PSJTMP))
if PSJTMP=""
QUIT
SET CSCHED=CSCHED_PSJTMP_","
+5 IF $EXTRACT(CSCHED,$LENGTH(CSCHED))=","
SET CSCHED=$EXTRACT(CSCHED,1,$LENGTH(CSCHED)-1)_")"
End DoDot:1
+6 QUIT CSCHED
+7 ;
CABSTR(PSJINP) ; Return string of PADE cabinets from array PSJINP("PADEV",CABINET)
+1 NEW CABSTR
NEW PSJTMP,PSJII,PSJDONE
+2 SET PSJTMP=0
FOR PSJII=0:1
SET PSJTMP=$ORDER(PSJINP("PADEV",PSJTMP))
if 'PSJTMP!$GET(PSJDONE)
QUIT
Begin DoDot:1
+3 IF $GET(PSJINP("PADEV"))="ALL"
SET CABSTR="ALL"
SET PSJDONE=1
QUIT
+4 IF $LENGTH($GET(CABSTR))+$LENGTH($PIECE($GET(^PS(58.63,+PSJTMP,0)),"^"))>140
SET CABSTR=CABSTR_" >> more..."
SET PSJDONE=1
QUIT
+5 SET CABSTR=$SELECT(PSJII:$GET(CABSTR)_",",1:"")_$PIECE($GET(^PS(58.63,+PSJTMP,0)),"^")
End DoDot:1
+6 QUIT CABSTR
+7 ;
DRGSTR(PSJINP) ; Return string of PADE drugs selected by user from PSJINP("PSDRG",DRUG IEN)
+1 NEW PADEDRG,PSJTMP,PSJII,PSJDONE
+2 SET PADEDRG=""
SET PSJTMP=""
FOR PSJII=0:1
SET PSJTMP=$ORDER(PSJINP("PSDRG",PSJTMP))
if 'PSJTMP!$GET(PSJDONE)
QUIT
Begin DoDot:1
+3 IF $GET(PSJINP("PSDRG"))="ALL"
SET PADEDRG="ALL"
SET PSJDONE=1
QUIT
+4 SET PADEDRG=$SELECT(PSJII:(PADEDRG_","),1:"")_$PIECE($GET(^PSDRUG(+PSJTMP,0)),"^")
+5 IF $LENGTH(PADEDRG)>187
SET PADEDRG=PADEDRG_" > more..."
SET PSJDONE=1
QUIT
End DoDot:1
+6 if $EXTRACT(PADEDRG,$LENGTH(PADEDRG))
SET PADEDRG=$EXTRACT(PADEDRG,1,$LENGTH(PADEDRG)=1)
+7 QUIT PADEDRG
+8 ;
SETCOLS(PSJINP,COL) ; Set column widths
+1 IF $GET(PSJINP("PSJSUM"))="S"
Begin DoDot:1
+2 SET COL(1)=0
SET COL(2)=2
SET COL(3)=50
SET COL(4)=60
SET COL(5)=68
SET COL(6)=74
End DoDot:1
+3 IF $GET(PSJINP("PSJSUM"))="D"
Begin DoDot:1
+4 SET COL(1)=0
SET COL(2)=38
SET COL(3)=48
SET COL(4)=53
SET COL(5)=64
SET COL(6)=75
End DoDot:1
+5 QUIT
+6 ;
TRANSTR(PSJINP) ; Return string of transaction types selected
+1 NEW TRANS,TMP,II,PATFLG
+2 SET PATFLG=$$PTTRFLG^PSJPDRU1(.PSJINP)
+3 SET TRANS=""
+4 IF $GET(PSJINP("PSJTRANS"))="ALL"&(PATFLG=1)
QUIT "ALL"
+5 IF $GET(PSJINP("PSJTRANS"))="ALL"&(PATFLG=2)
QUIT "ALL PATIENT TRANSACTIONS"
+6 IF $GET(PSJINP("PSJTRANS"))="ALL"&'PATFLG
QUIT "ALL NON-PATIENT TRANSACTIONS"
+7 SET TMP=""
FOR II=0:1
SET TMP=$ORDER(PSJINP("PSJTRANS",TMP))
if TMP=""
QUIT
SET TRANS=$SELECT(II:TRANS_","_PSJINP("PSJTRANS",TMP),1:PSJINP("PSJTRANS",TMP))
+8 QUIT TRANS
+9 ;
CABST(PSJPSYS,PSJPADE) ; Return PADE Status : (I)=Inactive or null
+1 NEW STATUS,PADIEN
+2 if '$GET(PSJPSYS)
QUIT ""
+3 if $GET(PSJPADE)=""
QUIT ""
+4 SET PADIEN=$$FIND1^DIC(58.63,,,PSJPADE)
+5 if 'PADIEN
QUIT ""
+6 SET STATUS=$PIECE($GET(^PS(58.63,+PADIEN,0)),"^",4)
+7 SET STATUS=$SELECT(STATUS="I":"(I)",1:"")
+8 QUIT STATUS
+9 ;
XALL(IN) ; Convert partial ^ALL to ALL
+1 NEW OUT
+2 SET OUT=IN
+3 IF ($EXTRACT(IN)'="^")!(IN="^")
QUIT OUT
+4 SET OUT=$$ENLU^PSGMI(OUT)
+5 IF $EXTRACT(OUT,1,$LENGTH(OUT))=$EXTRACT("^ALL",1,$LENGTH(OUT))
Begin DoDot:1
+6 SET OUT="ALL"
+7 KILL DUOUT,DTOUT
End DoDot:1
+8 QUIT OUT
+9 ;
CONT2(PGCNT,PSJQUIT,PSJEND) ; Press return to continue
+1 NEW DIR
+2 IF ($EXTRACT($GET(IOST))="C")
WRITE !
Begin DoDot:1
+3 IF $GET(PSJEND)
SET DIR("A")="End of Report. Press Return to continue"
SET PSJQUIT=1
+4 if '$DATA(DIR("A"))
SET DIR("A")="Press Return to continue or '^' to exit"
+5 SET DIR(0)="FO"
+6 DO ^DIR
KILL DIR
+7 IF $GET(DTOUT)!$GET(DUOUT)
SET PSJQUIT=1
+8 WRITE @IOF
End DoDot:1
if $GET(PSJQUIT)
QUIT
+9 SET PGCNT=$GET(PGCNT)+1
+10 QUIT
+11 ;
CNVTYP(INTYP,PSJOUT) ; Convert Transaction Types to external format from raw HL7
+1 NEW TTCNT,PSJOUTE
KILL PSJOUT
+2 SET TTCNT=0
FOR
SET TTCNT=$ORDER(INTYP(TTCNT))
if 'TTCNT
QUIT
Begin DoDot:1
+3 NEW TTNAME,TTCODE
SET TTNAME=INTYP(TTCNT)
+4 SET TTCODE=$$EXTT^PSJPDRUT(TTNAME)
+5 IF TTCODE]""
SET PSJOUT(TTCODE)=TTNAME
+6 QUIT
+7 IF $EXTRACT(INTYP(TTCNT))="D"
SET PSJOUT("V")="VEND"
SET PSJOUT("I")="ISSUE"
QUIT
+8 IF $EXTRACT(INTYP(TTCNT))="L"
SET PSJOUT("L")="LOAD"
QUIT
+9 IF $EXTRACT(INTYP(TTCNT))="F"
SET PSJOUT("F")="FILL"
QUIT
+10 IF $EXTRACT(INTYP(TTCNT))="U"
SET PSJOUT("U")="UNLOAD"
QUIT
+11 IF $EXTRACT(INTYP(TTCNT))="B"
SET PSJOUT("B")="EMPTY BIN"
QUIT
+12 IF $EXTRACT(INTYP(TTCNT))="C"
SET PSJOUT("C")="COUNT"
QUIT
+13 IF $EXTRACT(INTYP(TTCNT))="R"
SET PSJOUT("R")="RETURN"
QUIT
+14 IF $EXTRACT(INTYP(TTCNT))="W"
SET PSJOUT("W")="WASTE"
QUIT
+15 IF $EXTRACT(INTYP(TTCNT))="E"
SET PSJOUT("E")="EXPIRED"
QUIT
+16 IF INTYP(TTCNT)="Destock"
SET PSJOUT("D")="DESTOCK"
QUIT
End DoDot:1
+17 QUIT
+18 ;
ALLSCHED(PSJCSUB,SCHLST) ; Return all CS Federal Schedules in PSJCSUB(SCHEDULE)
+1 NEW SCHED,SCNT
+2 FOR SCNT=1:1:$LENGTH(SCHLST,";")
SET SCHED=$PIECE(SCHLST,";",SCNT)
SET PSJCSUB($PIECE(SCHED,":"))=$PIECE(SCHED,":",2)
+3 QUIT
+4 ;
DIV(PSJDIV,PSJSTOP) ; Get Division
+1 NEW DIC,X,Y,PSJDONE,PSDIVLST,PSJDIC
+2 SET DIC("S")="I $D(^PS(58.63,""D"",+Y))"
+3 SET PSJSTOP=0
+4 DO LIST^DIC(40.8,,,"P",,,,,DIC("S"),,"PSDIVLST")
+5 SET PSJDIC=0
FOR
SET PSJDIC=$ORDER(PSDIVLST("DILIST",PSJDIC))
if 'PSJDIC
QUIT
Begin DoDot:1
+6 SET PSDIVLST=+$GET(PSDIVLST("DILIST",PSJDIC,0))
+7 SET PSDIVLST("PSJDIV",PSDIVLST)=""
End DoDot:1
+8 SET PSJDIV=""
KILL PSJDONE,PSJDIV
+9 SET DIC("S")="I $D(^PS(58.63,""D"",+Y))"
+10 DO DIV^PSJPDRUT(.PSJDIV,.PSJSTOP)
+11 QUIT
