Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOCMOPR

PSOCMOPR.m

Go to the documentation of this file. 
  1. PSOCMOPR ;BHAM ISC/PDW - CMOP CONTROLLED SUBSTANCE RX DISPENSE REPORT ; 05 Nov 1999  9:39 AM
  1.  ;;7.0;OUTPATIENT PHARMACY;**33,52**;DEC 1997
  1.  ; External reference to file #550.2 granted by DBIA 2231
  1.  ; External reference to file #50 granted by DBIA 221
  1.  Q
  1.  ;
  1. S ;ENTRY
  1.  I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"A Pharmacy Division Must Be Selected!",! G EXIT
  1.  ; check for multi divisions
  1.  ;
  1.  S X=0,I=0 F  S I=$O(^PS(59,I)) Q:'I  S X=X+1
  1.  I X<2 S QDIV="A" G CNT1
  1.  K DIR S DIR(0)="SA^A:All divisions;S:Single division"
  1.  S DIR("A")="Print for (A)ll or a (S)ingle division? (A/S) "
  1.  S DIR("B")="S"
  1.  D ^DIR K DIR
  1.  G:$D(DIRUT) EXIT
  1.  S QDIV=Y
  1.  ; select division if QDIV="S"
  1.  I QDIV="S" D  G:Y'>0 S
  1.  . K DIC
  1.  . S DIC(0)="AEQM",DIC=59 D ^DIC
  1.  . S:+Y QDIV=+Y
  1.  . K DIC
  1. CNT1 ;Continue point 1
  1.  K DIR S DIR(0)="S^1:Sort by Release Date;2:Sort by Drug"
  1.  S DIR("A")="Select one of the following: "
  1.  S DIR("B")=1
  1.  D ^DIR K DIR
  1.  G:$D(DIRUT) EXIT
  1.  S QSORT=Y
  1. DATE ; ask date range
  1.  K %DT
  1.  S %DT(0)="-NOW",%DT("A")="Enter Start date: ",%DT="AEPX" D ^%DT
  1.  G:"^"[$E(X) EXIT
  1.  S (%DT(0),SCANBDT)=Y
  1.  S Y=DT X ^DD("DD") S END=Y S %DT("A")="Ending date: ",%DT("B")=END D ^%DT K %DT
  1.  G:"^"[$E(X) EXIT
  1.  S SCANEDT=Y D DD^%DT S EDATE=Y
  1.  S Y=SCANBDT D DD^%DT S BDATE=Y
  1.  ;
  1.  W !!,"This report is designed for a 132-column format.",!
  1.  W !,"It is recommended that this report be queued.",!!
  1.  ;***
  1.  K IO("Q"),%ZIS,IOP,ZTSK S %ZIS="Q"
  1.  D ^%ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
  1.  K PSOION
  1.  ; set subscript for ^XTMP storage
  1.  S PSOJOB=$J_"_"_$P($H,",",2)
  1.  S PSOSUB="PSO_CMOP_CS"_PSOJOB
  1.  ; setup queing
  1.  I $D(IO("Q")) D  G EXIT
  1.  . F X="BDATE","EDATE","QDIV","QSORT","SCANBDT","SCANEDT","PSOSUB" S ZTSAVE(X)=""
  1.  . S ZTRTN="DEQUEUE^PSOCMOPR",ZTDESC="Report of CMOP CS RX Dispenses"
  1.  . D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K ZTSK,IO("Q")
  1.  ;
  1. DEQUEUE ; TASKING RE-ENTRY POINT AND PROCESSING
  1.  D COMPUTE,PRINT
  1.  G EXIT
  1.  Q
  1. COMPUTE ; Deque point for computing
  1.  ; store in ^XTMP(PSOSUB, for printing queue
  1.  K ^XTMP(PSOSUB),PSOQUIT
  1.  S X1=DT,X2=2 D C^%DTC
  1.  S ^XTMP(PSOSUB,0)=X_U_DT_"^  Storage for CMOP-CS-RX STATUS DIVISION REPORT"
  1.  S SCANDT=SCANBDT\1-.1
  1.  ; Set status catagories
  1.  ;
  1.  F  S SCANDT=$O(^PSRX("AD",SCANDT)) Q:SCANDT>SCANEDT  Q:SCANDT'>0  D
  1.  . S RX=0 F  S RX=$O(^PSRX("AD",SCANDT,RX)) Q:RX'>0  D
  1.  .. S FILL="" F  S FILL=$O(^PSRX("AD",SCANDT,RX,FILL)) Q:FILL=""  D RX
  1.  Q
  1. RX ; check & gather RX,Fills data
  1.  ;
  1.  I '$D(^PSRX(RX,4)) Q  ;no CMOP events
  1.  I '$O(^PSRX(RX,4,0)) Q  ; no CMOP events
  1.  D CMOP ;                          get CMOP ST - FAC
  1.  Q:'TRANDA  ; no CMOP event for FILL
  1.  ;
  1.  ;    test for CS category 3,4,5 & C
  1.  S DRUGDA=$$GET1^DIQ(52,RX,6,"I")
  1.  S DEA=$$GET1^DIQ(50,DRUGDA,3)
  1.  I DEA'[3,DEA'[4,DEA'[5 Q
  1.  ;
  1.  ; get qty & div & reldt per original or refil
  1.  I FILL=0 S QTY=$$GET1^DIQ(52,RX,7),DIV=$$GET1^DIQ(52,RX,20),DIVDA=$$GET1^DIQ(52,RX,20,"I") S RELDT=$$GET1^DIQ(52,RX,31,"I") I 1
  1.  E  D
  1.  . S RXF=^PSRX(RX,1,FILL,0)
  1.  . S QTY=$P(RXF,U,4),DIVDA=$P(RXF,U,9)
  1.  . S RELDT=$P(RXF,U,18)
  1.  . S DIV=$$GET1^DIQ(59,DIVDA,.01)
  1.  ; test div if QDIV
  1.  I +QDIV,DIVDA'=QDIV Q
  1.  ;
  1.  S:RELDT="" RELDT="Not Released"
  1.  S DRUG=$$GET1^DIQ(50,DRUGDA,.01) ; get DRG;
  1.  S PAT=$$GET1^DIQ(52,RX,2) ;       get PAT
  1.  S PATDA=$$GET1^DIQ(52,RX,2,"I")
  1.  S SSN=$$GET1^DIQ(2,PATDA,.09),SSN="("_$E(SSN,6,9)_")"
  1.  ;
  1.  ; store according to sort
  1.  I QSORT=2 S ^XTMP(PSOSUB,DIV,DRUG,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
  1.  E  S ^XTMP(PSOSUB,DIV,RELDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
  1.  ;
  1.  Q
  1.  ;
  1. CMOP ;loop CMOP event for fill, status, and facility
  1.  ; sets TRANDA for XTMP subscript
  1.  S EVTRDA=0,TRANDA=0
  1.  S (ST,FAC)=""
  1.  ; loop events : EVTRDA will be the last event for the FILL in question
  1.  S EVDA=0
  1.  F  S EVDA=$O(^PSRX(RX,4,EVDA)) Q:EVDA'>0  S:FILL=$P(^(EVDA,0),U,3) EVTRDA=EVDA
  1.  Q:'EVTRDA
  1.  S EVENT=^PSRX(RX,4,EVTRDA,0)
  1.  S ST=$P(EVENT,U,4)
  1.  S ST=$S(ST=0:"T",ST=1:"D",ST=2:"RT",ST=3:"ND",1:"")
  1.  S TRANDA=$P(EVENT,U,1)
  1.  S FAC=$$GET1^DIQ(550.2,TRANDA,3)
  1.  K EVDA,EVTRDA
  1.  Q
  1. PRINT ; print entry point
  1.  K PSOQUIT,PSOPG,DIV
  1.  S PSOQUIT=0
  1.  D COLUMN ; set column spacing
  1.  D PGHDR
  1.  I $O(^XTMP(PSOSUB,0))="" D  G EXIT
  1.  . W !!,?5,"No Data To Report",!!
  1.  D:QSORT=1 BYDATE
  1.  D:QSORT=2 BYDRUG
  1.  K ^XTMP(PSOSUB)
  1.  Q
  1. BYDATE ; print report by release date
  1.  ;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
  1.  S DIV=0 F  S DIV=$O(^XTMP(PSOSUB,DIV)) Q:DIV=""  Q:$G(PSOQUIT)  D
  1.  . D DIVHDR
  1.  . S SCANDT=0 F  S SCANDT=$O(^XTMP(PSOSUB,DIV,SCANDT)) Q:SCANDT=""  Q:$G(PSOQUIT)  D
  1.  .. S TRANDA=0 F  S TRANDA=$O(^XTMP(PSOSUB,DIV,SCANDT,TRANDA)) Q:TRANDA'>0  Q:$G(PSOQUIT)  D PRTDATE
  1.  Q
  1. PRTDATE ; print by date output
  1.  ;^XTMP(PSOSUB,DIV,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
  1.  S X=^XTMP(PSOSUB,DIV,SCANDT,TRANDA)
  1.  S PAT=$P(X,U,1),SSN=$P(X,U,2),QTY=$P(X,U,3),ST=$P(X,U,4)
  1.  S FAC=$P(X,U,5),RX=$P(X,U,6),FILL=$P(X,U,7),DRUG=$P(X,U,8)
  1.  S (DATE,Y)=SCANDT I +Y D DD^%DT S DATE=Y
  1.  S PAT=PAT_" "_SSN
  1.  S RX=$$GET1^DIQ(52,RX,.01)
  1.  ;
  1.  D PG Q:$G(PSOQUIT)
  1.  W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QTY: ",QTY,!
  1.  Q
  1. BYDRUG ; pull in & print byDrug
  1.  ;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
  1.  S DIV=0 F  S DIV=$O(^XTMP(PSOSUB,DIV)) Q:DIV=""  Q:$G(PSOQUIT)  D
  1.  . D DIVHDR
  1.  . S DRUG="" F  S DRUG=$O(^XTMP(PSOSUB,DIV,DRUG)) Q:DRUG=""  Q:$G(PSOQUIT)  D
  1.  .. W !!,?3,DRUG
  1.  .. S SCANDT=0 F  S SCANDT=$O(^XTMP(PSOSUB,DIV,DRUG,SCANDT)) Q:SCANDT=""  Q:$G(PSOQUIT)  D
  1.  ... S TRANDA=0 F  S TRANDA=$O(^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)) Q:TRANDA'>0  Q:$G(PSOQUIT)  D PRTDRUG
  1.  Q 
  1. PRTDRUG ; print by Drug
  1.  ;^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)=PAT_U_SSN_U_QTY_U_ST_U_FAC_U_RX_U_FILL_U_DRUG
  1.  S X=^XTMP(PSOSUB,DIV,DRUG,SCANDT,TRANDA)
  1.  S PAT=$P(X,U,1),SSN=$P(X,U,2),QTY=$P(X,U,3),ST=$P(X,U,4)
  1.  S FAC=$P(X,U,5),RX=$P(X,U,6),FILL=$P(X,U,7)
  1.  S (DATE,Y)=SCANDT I +Y D DD^%DT S DATE=Y
  1.  S PAT=PAT_" "_SSN,RX=$$GET1^DIQ(52,RX,.01),RX=RX_" ("_FILL_")"
  1.  D PG Q:$G(PSOQUIT)
  1.  ;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
  1.  W !,DATE,?D1,RX,?D2,QTY,?D3,PAT,?D4,ST,?D5,FAC
  1.  Q
  1. EXIT ;EXIT
  1.  K BDATE,C1,C2,C3,C4,C5,C6,CMOP,D1,D2,D3,D4,D5,DATE,DEA,DIV,DIVDA,DRUG
  1.  K DRUGDA,EDATE,END,FAC,FIL,FLD,PAT,PATDA,PSOPG,PSOSUB,EVENT,RXF
  1.  K QDIV,QSORT,QTY,RX,SCANDT,SCANBDT,SCANEDT,SSN,ST,TRANDA,PSOQUIT
  1.  K FILL,EVDA,PSOJOB,PSOPAR,PSUIOP,PSUFQ,PSURC,PSURP,PSURX,PSUNS,X1,X2
  1.  D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q
  1. PG ;EP  Page controller
  1.  ;S PSOQUIT=0
  1.  Q:$G(PSOQUIT)
  1.  I $Y<(IOSL-4) Q
  1.  I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR I $D(DIRUT) S PSOQUIT=1 Q
  1.  ;
  1. PGHDR ; Write Page Header
  1.  U IO W @IOF
  1.  S PSOPG("PG")=$G(PSOPG("PG"))+1
  1.  W !,"CMOP Controlled Substance Prescription Dispensing Report",?(IOM-12),"Page: ",PSOPG("PG")
  1.  W !,BDATE," through ",EDATE
  1.  D:$D(DIV) DIVHDR
  1.  Q
  1.  ;
  1. DIVHDR ; write division header
  1.  S X=DIV_"  Division"
  1.  W !!,?((IOM-$L(X))\2),X,!!
  1.  I QSORT=1 D
  1.  . W !,"Release Date",?C1,"Rx#",?C2,"Patient",?C3,"CMOP",?C4,"CMOP"
  1.  . W !,?C3,"STATUS",?C4,"Facility",! ; RX at C5 QTY AT C6
  1.  . F X=1:1:IOM-2 W "-"
  1.  I QSORT=2 D
  1.  . W !,"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP"
  1.  . W !,?D4,"STATUS",?D5,"Facility",!
  1.  . F X=1:1:IOM-2 W "-"
  1.  . I PSOPG("PG")>1,$L($G(DRUG)) W !,?3,DRUG
  1.  Q
  1. COLUMN ; setup column spacing
  1. C1 ; setup column spacing for byDate
  1.  S C1=23,C2=39,C3=77,C4=85,C5=42
  1.  ;W !,DATE,?C1,RX_" ("_FILL_")",?C2,PAT,?C3,ST,?C4,FAC,!,DRUG,?C5,"QT: ",QTY
  1. D1 ; setup column spacing for byDrug
  1.  ;"Release Date",?D1,"Rx#",?D2,"QTY",?D3,"Patient",?D4,"CMOP",?D5,"CMOP
  1.  S D1=23,D2=39,D3=53,D4=91,D5=99
  1.  Q
  1. CLEAR ; clear ^XTMP
  1.  S X="PSO_CMOP_",Y=X
  1.  F  S X=$O(^XTMP(X)) Q:X'[Y  K ^XTMP(X)
  1.  Q