- 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 Jan 18, 2025@03:35:52 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