PSOSD ;BHAM ISC/SAB - action or informational profile ;11/18/92 18:30
;;7.0;OUTPATIENT PHARMACY;**2,17,155,176,300**;DEC 1997;Build 4
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSDRUG( supported by DBIA 221
;
START S X=$$SITE^VASITE,PSOINST=$P(X,"^",3) K X
K IOP,DIR S DIR("A")="Action or Informational (A or I): ",DIR("?",1)="Enter 'A' for action profile",DIR("?",2)=" 'I' for informational profile",DIR("?")=" 'E' to EXIT process",DIR("B")="A",DIR(0)="SAM^1:Action;0:Informational;E:Exit"
D ^DIR G:Y="E"!($D(DIRUT)) PAT1 S PSTYPE=Y
S PSONUM=0 I 'PSTYPE!'$P($G(PSOSYS),"^",6) S PSOPOL=0 G ASK
K DIR S DIR("A")="Do you want generate a Polypharmacy report?: ",DIR("?",1)="Enter 'Y' to generate report",DIR("?",2)=" 'N' if you do not want the report",DIR("?")=" 'E' to EXIT process",DIR("B")="NO",DIR(0)="SA^1:YES;0:NO;E:Exit"
D ^DIR S PSOPOL=$S(Y:1,1:0) G:Y="E"!($D(DIRUT)) PAT1 G:'PSOPOL ASK
K DIR S DIR("A")="Minimum Number of Active Prescriptions",DIR("B")=7,DIR(0)="N^1:100:0" D ^DIR S PSONUM=Y G:$D(DIRUT) PAT1
;
ASK K DIR S DIR("A")="By Patient, Clinic or Clinic Group (P/C/G): ",DIR("?",1)="Enter 'P' to print by patient ",DIR("?",2)=" 'C' for printing by clinic",DIR("?",3)=" 'G' for printing by clinic group"
S DIR("?")=" 'E' to exit process",DIR("B")="P",DIR(0)="SAM^P:Patient;C:Clinic;G:Clinic Group;E:Exit"
D ^DIR G:Y="E"!($D(DIRUT)) PAT1 S PSOUT=Y
K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 80 column or 132 column: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit"
D ^DIR G:Y="E"!($D(DIRUT)) PAT1 S PSORM=$S(Y=1:1,1:0) K DIR,X,Y
G:PSOUT="P" ^PSOSD1 G:PSOUT="G" CLSG^PSOSDP
CLINIC N RSLT K DIR,X,Y R !!,"FOR CLINIC (TYPE 'ALL' FOR ALL CLINICS): ",X:DTIME S:'$T X="^" G:"^"[X EXIT
S DIC="^SC(",DIC(0)="QEM",FR="ALL",TO="" I X'="ALL" D ^DIC G CLINIC:Y<0 S (FR,TO)=+Y
S %DT="AEFX",%DT("A")="FOR DATE: " D ^%DT G CLINIC:Y<0 S FR=FR_","_Y,TO=TO_","_Y_".2359",PSOT=Y
CLSG D DAYS^PSOSD1 G:$D(DIRUT) EXIT S X1=DT,X2=-PSDAYS D C^%DTC S PSDATE=X S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0),$P(LINE,"-",132)="-"
N PSOBARS,PSOBAR0,PSOBAR1
D DEV^PSOSDRAP Q:$D(DTOUT)!($D(DUOUT))
S (IOP,APRT)=ION,PSOIOS=IOS D DEVBAR^PSOBMST
K PSOION I $D(IO("Q")) S ZTDESC="Outpatient Pharmacy Action Profile",ZTRTN="QUE^PSOSD",ZTSAVE("ZTREQ")="@" D D EXIT G START
.F G="FR","TO","LINE","PSOT","APRT","PSOPOL","PSOSYS","PSOINST","PSOBAR0","PSOBAR1","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY","PSONUM","PSORM" S:$D(@G) ZTSAVE(G)=""
.S ZTSAVE("DOD*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K:'$G(LM) ZTSK,IO("Q")
;S DISTOP="I $D(DIRUT)"
I $P(FR,",",1)'="ALL" D CLINIC^PSOSDRAP
I $P(FR,",",1)="ALL" D CLINALL^PSOSDRAP
S (X,PSTY)=PSTYPE D EXIT S PSTYPE=PSTY Q:$G(CLSP) G START
;
PAT N K D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
S PSDT=PSDATE-1 I '$O(^PS(55,DFN,"P","A",PSDT)) D HD^PSOSD2 Q:$D(DIRUT) W !!?13,">>>> NO PRESCRIPTIONS ON FILE <<<<" G PAT1
K ^TMP($J,DFN),^TMP($J,"PRF"),^TMP($J,"ACT")
F Z1=0:0 S PSDT=$O(^PS(55,DFN,"P","A",PSDT)) Q:'PSDT D RX
I '$D(^TMP($J,"PRF")) D HD^PSOSD2 W !!?13,">>>>> NO CURRENT PRESCRIPTIONS DATA FOUND <<<<<" D PAT1 Q
D ^PSOSDP:$G(PSOPOL)&('$D(CLINICX))
D HD^PSOSD2:'$D(CLINICX)
D ^PSOSD0,PAT1 Q:($D(DIRUT))
Q
RX F J=0:0 S J=$O(^PS(55,DFN,"P","A",PSDT,J)) Q:'J D RX1
Q
RX1 Q:'$D(^PSRX(J,0)) S RXNO=J
S RX0=$G(^PSRX(J,0)),$P(RX0,"^",15)=+$G(^("STA")),RX2=$G(^(2)),RX3=$G(^(3)) I RX0]"" D
.S DRUG="" S:$D(^PSDRUG(+$P(RX0,"^",6),0)) DRUG=$P(^(0),"^"),CLASS=$P(^(0),"^",2) S:CLASS="" CLASS="zz" I DRUG]"" D STAT^PSOFUNC,STORE
.I $G(PSOPOL),$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3)'["S" S:'$D(^TMP($J,DFN)) ^TMP($J,DFN)=0 S:"05"[$E(+$P(RX0,"^",15)) ^TMP($J,DFN)=^TMP($J,DFN)+1,^TMP($J,DFN,DRUG,J)=""
Q
PAT1 K DUPD,DIR,X,Y,CLASS,ZCLASS,DRUG,CLAPP,HDFL,RXN,PSDOB,ADDR,RX,ST,ST0,II,FA,FN,PRI,DIC,PSRENW,PSLC,PI,Z2,Z,P,Z0,Z1,Z3,Z4,Z5,FDATE,AL,RFL,DRG,ELN,FDT,FILLDATE,FN,LN,PSOIFSUP,PSOPRPAS,RX3,RXCNT,SG,SGC,PSOUT,PSOPOLP
Q
;
STORE I $P(^PSRX(J,"STA"),"^")=13!($P($G(^(3)),"^",7)="CANCELLED FROM SUSPENSE BEFORE FILLING")!($P($G(^(3)),"^",7)="DISCONTINUED FROM SUSPENSE BEFORE FILLING") Q
I 'PSDAYS,ST]"","DE"[$E(ST) Q
S FILLDATE=9999999-$P(^PSRX(J,3),"^") I "DE"[$E(ST) S FILLDATE=FILLDATE+10000
I $E(ST)="D" S CNDT=0 F PSIIX=0:0 S PSIIX=$O(^PSRX(J,"A",PSIIX)) Q:'PSIIX I $P($G(^(0)),"^",2)="C",+$P(^(0),"^")>CNDT S CNDT=+$P(^(0),"^")
Q:"AHPSDE"'[$E(ST) S ^TMP($J,"PRF",CLASS,DRUG,FILLDATE,J)=$P(RX0,"^",1,14)_"^"_ST_"^"_$S($D(CNDT):CNDT,1:"") S:"AHPS"[$E(ST) ^TMP($J,"ACT",CLASS,DRUG)=""
K CNDT Q
;
EXIT K ^TMP($J,"PRF"),^("ACT"),PSOT,%DT,ADDR,ADDRFL,BY,CLASS,PCLASS,CLDT
K CLINICX,CNDT,DFN,DHD,DRUG,FLDS,FR,CLAPP,HDFL,I,II,J,L,LINE,P,POP,PSDATE
K PSDAYS,PSDOB,PSIIX,PSNAME,PSSN,PSTYPE,RX,RX0,RX2,RX3,RXN,ST,ST0,TO,VAR,Z1
K APRT,DIE,DR,X,Y,DIC,ZTSAVE,PSORM,PSOUT,PSOPOLP,G,LM,PSDT,ZTDESC,ZTRTN,ZTSK
K PSOIOS,PSONUM,PSOPOL,RXNO,X1,X2,RSLT,DIR,DIRUT,DTOUT,DUOUT
K CS,DOD,GMRVSTR,PAGE,PSOBAR2,PSOBAR3,PSOBAR4,VA,VADM,VAPA,VAIN
D ^%ZISC
Q
ACT ;
S PSTYPE=1 G START
INFO ;
S PSTYPE=0 G START
;
QUE ;prints clinics when queued
I $P(FR,",",1)'="ALL" D CLINIC^PSOSDRAP
I $P(FR,",",1)="ALL" D CLINALL^PSOSDRAP
D EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSD 5328 printed Apr 09, 2024@21:31:35 Page 2
PSOSD ;BHAM ISC/SAB - action or informational profile ;11/18/92 18:30
+1 ;;7.0;OUTPATIENT PHARMACY;**2,17,155,176,300**;DEC 1997;Build 4
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PSDRUG( supported by DBIA 221
+4 ;
START SET X=$$SITE^VASITE
SET PSOINST=$PIECE(X,"^",3)
KILL X
+1 KILL IOP,DIR
SET DIR("A")="Action or Informational (A or I): "
SET DIR("?",1)="Enter 'A' for action profile"
SET DIR("?",2)=" 'I' for informational profile"
SET DIR("?")=" 'E' to EXIT process"
SET DIR("B")="A"
SET DIR(0)="SAM^1:Action;0:Informational;E:Exit"
+2 DO ^DIR
if Y="E"!($DATA(DIRUT))
GOTO PAT1
SET PSTYPE=Y
+3 SET PSONUM=0
IF 'PSTYPE!'$PIECE($GET(PSOSYS),"^",6)
SET PSOPOL=0
GOTO ASK
+4 KILL DIR
SET DIR("A")="Do you want generate a Polypharmacy report?: "
SET DIR("?",1)="Enter 'Y' to generate report"
SET DIR("?",2)=" 'N' if you do not want the report"
SET DIR("?")=" 'E' to EXIT process"
SET DIR("B")="NO"
SET DIR(0)="SA^1:YES;0:NO;E:Exit"
+5 DO ^DIR
SET PSOPOL=$SELECT(Y:1,1:0)
if Y="E"!($DATA(DIRUT))
GOTO PAT1
if 'PSOPOL
GOTO ASK
+6 KILL DIR
SET DIR("A")="Minimum Number of Active Prescriptions"
SET DIR("B")=7
SET DIR(0)="N^1:100:0"
DO ^DIR
SET PSONUM=Y
if $DATA(DIRUT)
GOTO PAT1
+7 ;
ASK KILL DIR
SET DIR("A")="By Patient, Clinic or Clinic Group (P/C/G): "
SET DIR("?",1)="Enter 'P' to print by patient "
SET DIR("?",2)=" 'C' for printing by clinic"
SET DIR("?",3)=" 'G' for printing by clinic group"
+1 SET DIR("?")=" 'E' to exit process"
SET DIR("B")="P"
SET DIR(0)="SAM^P:Patient;C:Clinic;G:Clinic Group;E:Exit"
+2 DO ^DIR
if Y="E"!($DATA(DIRUT))
GOTO PAT1
SET PSOUT=Y
+3 KILL DIR,DTOUT,DIRUT,DUOUT
SET DIR("A")="Do you want this Profile to print in 80 column or 132 column: "
SET DIR("B")="132"
SET DIR(0)="SAM^1:132;8:80;E:Exit"
+4 DO ^DIR
if Y="E"!($DATA(DIRUT))
GOTO PAT1
SET PSORM=$SELECT(Y=1:1,1:0)
KILL DIR,X,Y
+5 if PSOUT="P"
GOTO ^PSOSD1
if PSOUT="G"
GOTO CLSG^PSOSDP
CLINIC NEW RSLT
KILL DIR,X,Y
READ !!,"FOR CLINIC (TYPE 'ALL' FOR ALL CLINICS): ",X:DTIME
if '$TEST
SET X="^"
if "^"[X
GOTO EXIT
+1 SET DIC="^SC("
SET DIC(0)="QEM"
SET FR="ALL"
SET TO=""
IF X'="ALL"
DO ^DIC
if Y<0
GOTO CLINIC
SET (FR,TO)=+Y
+2 SET %DT="AEFX"
SET %DT("A")="FOR DATE: "
DO ^%DT
if Y<0
GOTO CLINIC
SET FR=FR_","_Y
SET TO=TO_","_Y_".2359"
SET PSOT=Y
CLSG DO DAYS^PSOSD1
if $DATA(DIRUT)
GOTO EXIT
SET X1=DT
SET X2=-PSDAYS
DO C^%DTC
SET PSDATE=X
SET PSTYPE=$SELECT($DATA(PSTYPE):PSTYPE,1:0)
SET $PIECE(LINE,"-",132)="-"
+1 NEW PSOBARS,PSOBAR0,PSOBAR1
+2 DO DEV^PSOSDRAP
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 SET (IOP,APRT)=ION
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
+4 KILL PSOION
IF $DATA(IO("Q"))
SET ZTDESC="Outpatient Pharmacy Action Profile"
SET ZTRTN="QUE^PSOSD"
SET ZTSAVE("ZTREQ")="@"
Begin DoDot:1
+5 FOR G="FR","TO","LINE","PSOT","APRT","PSOPOL","PSOSYS","PSOINST","PSOBAR0","PSOBAR1","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY","PSONUM","PSORM"
if $DATA(@G)
SET ZTSAVE(G)=""
+6 SET ZTSAVE("DOD*")=""
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report Queued to Print !!",!
if '$GET(LM)
KILL ZTSK,IO("Q")
End DoDot:1
DO EXIT
GOTO START
+7 ;S DISTOP="I $D(DIRUT)"
+8 IF $PIECE(FR,",",1)'="ALL"
DO CLINIC^PSOSDRAP
+9 IF $PIECE(FR,",",1)="ALL"
DO CLINALL^PSOSDRAP
+10 SET (X,PSTY)=PSTYPE
DO EXIT
SET PSTYPE=PSTY
if $GET(CLSP)
QUIT
GOTO START
+11 ;
PAT NEW K
if $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
DO EN^PSOHLUP(DFN)
+1 SET PSDT=PSDATE-1
IF '$ORDER(^PS(55,DFN,"P","A",PSDT))
DO HD^PSOSD2
if $DATA(DIRUT)
QUIT
WRITE !!?13,">>>> NO PRESCRIPTIONS ON FILE <<<<"
GOTO PAT1
+2 KILL ^TMP($JOB,DFN),^TMP($JOB,"PRF"),^TMP($JOB,"ACT")
+3 FOR Z1=0:0
SET PSDT=$ORDER(^PS(55,DFN,"P","A",PSDT))
if 'PSDT
QUIT
DO RX
+4 IF '$DATA(^TMP($JOB,"PRF"))
DO HD^PSOSD2
WRITE !!?13,">>>>> NO CURRENT PRESCRIPTIONS DATA FOUND <<<<<"
DO PAT1
QUIT
+5 if $GET(PSOPOL)&('$DATA(CLINICX))
DO ^PSOSDP
+6 if '$DATA(CLINICX)
DO HD^PSOSD2
+7 DO ^PSOSD0
DO PAT1
if ($DATA(DIRUT))
QUIT
+8 QUIT
RX FOR J=0:0
SET J=$ORDER(^PS(55,DFN,"P","A",PSDT,J))
if 'J
QUIT
DO RX1
+1 QUIT
RX1 if '$DATA(^PSRX(J,0))
QUIT
SET RXNO=J
+1 SET RX0=$GET(^PSRX(J,0))
SET $PIECE(RX0,"^",15)=+$GET(^("STA"))
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
IF RX0]""
Begin DoDot:1
+2 SET DRUG=""
if $DATA(^PSDRUG(+$PIECE(RX0,"^",6),0))
SET DRUG=$PIECE(^(0),"^")
SET CLASS=$PIECE(^(0),"^",2)
if CLASS=""
SET CLASS="zz"
IF DRUG]""
DO STAT^PSOFUNC
DO STORE
+3 IF $GET(PSOPOL)
IF $PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^",3)'["S"
if '$DATA(^TMP($JOB,DFN))
SET ^TMP($JOB,DFN)=0
if "05"[$EXTRACT(+$PIECE(RX0,"^",15))
SET ^TMP($JOB,DFN)=^TMP($JOB,DFN)+1
SET ^TMP($JOB,DFN,DRUG,J)=""
End DoDot:1
+4 QUIT
PAT1 KILL DUPD,DIR,X,Y,CLASS,ZCLASS,DRUG,CLAPP,HDFL,RXN,PSDOB,ADDR,RX,ST,ST0,II,FA,FN,PRI,DIC,PSRENW,PSLC,PI,Z2,Z,P,Z0,Z1,Z3,Z4,Z5,FDATE,AL,RFL,DRG,ELN,FDT,FILLDATE,FN,LN,PSOIFSUP,PSOPRPAS,RX3,RXCNT,SG,SGC,PSOUT,PSOPOLP
+1 QUIT
+2 ;
STORE IF $PIECE(^PSRX(J,"STA"),"^")=13!($PIECE($GET(^(3)),"^",7)="CANCELLED FROM SUSPENSE BEFORE FILLING")!($PIECE($GET(^(3)),"^",7)="DISCONTINUED FROM SUSPENSE BEFORE FILLING")
QUIT
+1 IF 'PSDAYS
IF ST]""
IF "DE"[$EXTRACT(ST)
QUIT
+2 SET FILLDATE=9999999-$PIECE(^PSRX(J,3),"^")
IF "DE"[$EXTRACT(ST)
SET FILLDATE=FILLDATE+10000
+3 IF $EXTRACT(ST)="D"
SET CNDT=0
FOR PSIIX=0:0
SET PSIIX=$ORDER(^PSRX(J,"A",PSIIX))
if 'PSIIX
QUIT
IF $PIECE($GET(^(0)),"^",2)="C"
IF +$PIECE(^(0),"^")>CNDT
SET CNDT=+$PIECE(^(0),"^")
+4 if "AHPSDE"'[$EXTRACT(ST)
QUIT
SET ^TMP($JOB,"PRF",CLASS,DRUG,FILLDATE,J)=$PIECE(RX0,"^",1,14)_"^"_ST_"^"_$SELECT($DATA(CNDT):CNDT,1:"")
if "AHPS"[$EXTRACT(ST)
SET ^TMP($JOB,"ACT",CLASS,DRUG)=""
+5 KILL CNDT
QUIT
+6 ;
EXIT KILL ^TMP($JOB,"PRF"),^("ACT"),PSOT,%DT,ADDR,ADDRFL,BY,CLASS,PCLASS,CLDT
+1 KILL CLINICX,CNDT,DFN,DHD,DRUG,FLDS,FR,CLAPP,HDFL,I,II,J,L,LINE,P,POP,PSDATE
+2 KILL PSDAYS,PSDOB,PSIIX,PSNAME,PSSN,PSTYPE,RX,RX0,RX2,RX3,RXN,ST,ST0,TO,VAR,Z1
+3 KILL APRT,DIE,DR,X,Y,DIC,ZTSAVE,PSORM,PSOUT,PSOPOLP,G,LM,PSDT,ZTDESC,ZTRTN,ZTSK
+4 KILL PSOIOS,PSONUM,PSOPOL,RXNO,X1,X2,RSLT,DIR,DIRUT,DTOUT,DUOUT
+5 KILL CS,DOD,GMRVSTR,PAGE,PSOBAR2,PSOBAR3,PSOBAR4,VA,VADM,VAPA,VAIN
+6 DO ^%ZISC
+7 QUIT
ACT ;
+1 SET PSTYPE=1
GOTO START
INFO ;
+1 SET PSTYPE=0
GOTO START
+2 ;
QUE ;prints clinics when queued
+1 IF $PIECE(FR,",",1)'="ALL"
DO CLINIC^PSOSDRAP
+2 IF $PIECE(FR,",",1)="ALL"
DO CLINALL^PSOSDRAP
+3 DO EXIT
+4 QUIT
