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

APSPNUM.m

Go to the documentation of this file. 
  1. APSPNUM ;IHS/DSD/JRR/JCM - READS ALL RX# AND LIST OF NUMBERS  [ 03/06/2002  2:16 PM ];02-Sep-2005 11:24;SM
  1.  ;;7.0;OUTPATIENT PHARMACY;**1002,1003**;09/03/97
  1.  ; This utility is used to take user selection for rx's or patient
  1.  ; selection.
  1.  ; The entry point is EN and PSONUM would be defined to "RX" if
  1.  ; actual rx numbers are to be input or to "LIST" if a range of
  1.  ; numbers after the showing of a screen profile are to be
  1.  ; evaluated.
  1.  ;
  1.  ; Input Variables: PSONUM = "RX" for Rx# input
  1.  ;                  PSONUM = "LIST" to show profile and choose range
  1.  ;
  1.  ; Output Variables : PSOLIST(#) contains list of RX internal entry
  1.  ;                    numbers separated by commas, if more than 220
  1.  ;                    characters, the next node of PSOLIST( will be
  1.  ;                    defined
  1.  ;
  1.  ;                  PSORX("BAR CODE")=1 if bar coding was used to
  1.  ;                  input the numbers
  1.  ;
  1.  ;                  PSODFN if the PT entry point is used
  1.  ;_________________________________________________________________
  1.  ; Modified - IHS/CIA/PLS - 01/21/04 - Copy of PSONUM from OP v6.0
  1.  ;                          12/27/04 - Line LIST+2
  1. START ;
  1.  K PSOLIST
  1.  I '$D(PSOINST) S PSOINST="000" I $D(^DD("SITE",1)) S PSOINST=^DD("SITE",1)
  1.  I '$P(PSOPAR,"^",21) D GETRXM
  1.  I $P(PSOPAR,"^",21) D RANGE
  1.  G:$G(PSONUM)']"" END
  1. EN ; EP
  1.  K PSOLIST
  1.  D:PSONUM="RX" GETRXM
  1.  D:PSONUM="LIST" RANGE
  1.  G END
  1.  ;
  1. EN1 ;
  1.  K PSOLIST
  1.  D GETRXM
  1.  I $G(PSOQFLG)'=1,$Q(PSOLIST)']"" G EN1
  1.  G END
  1. PT ; EP
  1.  D PAT
  1.  ;
  1. END D EOJ
  1.  Q
  1.  ;------------------------------------------------------------------
  1. GETRXM ;
  1.  K Y
  1.  W !!,$S($G(PSONUM("A"))]"":PSONUM("A"),1:"Select")_" Rx #(s) => "
  1.  R X:DTIME
  1.  I '$T!(X["^") S PSOQFLG=1 K PSOLIST Q
  1.  I X="" S:'$D(PSORX("BAR CODE")) PSOQFLG=1 K:'$D(PSORX("BAR CODE")) PSOLIST Q
  1.  I X["?" D QUES3 G GETRXM
  1.  I "Pp"[$E(X) S:$D(PSOFROM("PTLKUP")) PSONUM="LIST" G GETRXMX
  1.  I 'X D QUES3 G GETRXM
  1.  I X["-" D BARCODE G GETRXM
  1.  D DUPCHK ;return Y with RXM list
  1.  G:Y="" GETRXM
  1.  F I=1:1:$L(Y,",") S RXM=$P(Y,",",I) S GOOD=$D(^PSRX("B",RXM)) W:'GOOD !!?5,"Couldn't Find RX # ",RXM I GOOD S RXN=$O(^PSRX("B",RXM,0)) D LIST
  1.  I $Q(PSOLIST)']"" G GETRXM
  1. GETRXMX Q
  1.  ;
  1. BARCODE ;
  1.  I X'?3N1"-"1.N W !?7,*7,*7,*7,"Improper Barcode Format" G BARCODEX
  1.  I $P(X,"-")'=PSOINST W !?7,*7,*7,*7,"Not From this Institution" G BARCODEX
  1.  S RXN=$P(X,"-",2),PSORX("BAR CODE")=1
  1.  D LIST
  1. BARCODEX Q
  1.  ;
  1. LIST ;
  1.  I $G(^PSRX(RXN,0))']"" W !,*7,"Rx data is not on file !",! G LISTX
  1.  ; IHS/CIA/PLS - 12/27/04
  1.  ;I $P(^PSRX(RXN,0),"^",15)=13 S RXN1=RXN,PSVD=1 D  I PSVD W !,*7,"Rx # ",RXM," has been deleted." G LISTX
  1.  I $G(^PSRX(RXN,"STA"))=13 S RXN1=RXN,PSVD=1 D  I PSVD W !,*7,"Rx # ",RXM," has been deleted." G LISTX
  1.  .;F  S RXN1=$O(^PSRX("B",RXM,RXN1)) Q:'RXN1  I $P($G(^PSRX(RXN1,0)),"^",15)'=13 S RXN=RXN1,PSVD=0
  1.  .F  S RXN1=$O(^PSRX("B",RXM,RXN1)) Q:'RXN1  I $G(^PSRX(RXN1,"STA"))'=13 S RXN=RXN1,PSVD=0
  1.  I $G(PSOLIST(1))']"" S PSOLIST(1)=RXN_"," G LISTX
  1.  F PSOX1=0:0 S PSOX1=$O(PSOLIST(PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
  1.  I $L(PSOLIST(PSOX2))+$L(RXN)<220 S:RXN_","'[PSOLIST(PSOX2) PSOLIST(PSOX2)=PSOLIST(PSOX2)_RXN_","
  1.  E  S:RXN_","'[PSOLIST(PSOX2+1) PSOLIST(PSOX2+1)=RXN_","
  1. LISTX K PSOX1,PSOX2,RXN,PSVD,RXN1
  1.  Q
  1.  ;
  1. RANGE ;
  1.  I '$D(PSOSD) D ^PSOBUILD
  1.  I $D(PSOSD)'>1 W !,"This patient has no prescriptions to act on. " G RANGEX
  1.  S PSOHI=PSOSD
  1.  I $G(PSOOPT)'=3,$G(PSOOPT)'=4 N:$G(PSOOPT)]"" PSOOPT S PSOOPT=-1
  1.  ;D ^PSODSPL Q:PSOQFLG  ;display profile
  1.  ;I '$G(APSPFLG) D ^PSODSPL Q:PSOQFLG  ;IHS/DSD/ENM 3/29/93 display profile
  1.  I '$G(APSPFLG) D ^PSODSPL Q:$G(PSOQFLG)  ;IHS/DSD/ENM 3/29/93 display profile
  1.  ;  dmh 2/27/2002  commented out one before and added next with $G
  1.  S PSOHI=PSOSD  ;dmh added 3/1/2002  it must get deleted in PSODSPL
  1.  ;    ;dmh I need this for the PRINT PATIENT MEDICATION SHEETS
  1.  ;    ;3/1/2002
  1.  D ^APSPLIST ;select range of #s to refill
  1.  I 'Y Q
  1.  F PS=1:1 Q:'$D(Y(PS))
  1.  S M=1,PSOLIST(1)=""
  1.  ;F I=1:1:PS-1 F J=1:1:$L(Y(I),",") S N=$P(Y(I),",",J) S DRG="" F K=1:1:N S DRG=$O(PSOSD("ACTIVE",DRG)),RXN=+PSOSD("ACTIVE",DRG) S:K=N PSOLIST(M)=PSOLIST(M)_RXN_"," S:$L(PSOLIST(M)_RXN_1)>220 M=M+1,PSOLIST(M)=""
  1.  ;
  1.  ;  IHS/BAO/DMH dmh  3/6/2002   modified if no more in "ACTIVE" list Q
  1.  F I=1:1:PS-1 F J=1:1:$L(Y(I),",") S N=$P(Y(I),",",J) S DRG="" F K=1:1:N S DRG=$O(PSOSD("ACTIVE",DRG)) Q:DRG=""  S RXN=+PSOSD("ACTIVE",DRG) S:K=N PSOLIST(M)=PSOLIST(M)_RXN_"," S:$L(PSOLIST(M)_RXN_1)>220 M=M+1,PSOLIST(M)=""
  1.  ;
  1.  ;   dmh commented out the below 4 lines and added to the one above the
  1.  ;   "ACTIVE" node on it....3/4/2002
  1.  ;
  1.  ;  dmh commented out above and added the next 3....2/27/2002
  1.  ;  the PSOSD array now has 2 subscripts.....
  1.  ;S BZD=""
  1.  ;F  S BZD=$O(PSOSD(BZD)) Q:BZD=""  D
  1.  .;S M=1,PSOLIST(1)=""
  1.  .;F I=1:1:PS-1 F J=1:1:$L(Y(I),",") S N=$P(Y(I),",",J) S DRG="" F K=1:1:N S DRG=$O(PSOSD(BZD,DRG)),RXN=+PSOSD(BZD,DRG) S:K=N PSOLIST(M)=PSOLIST(M)_RXN_"," S:$L(PSOLIST(M)_RXN_1)>220 M=M+1,PSOLIST(M)=""
  1.  ;K X,Y,DIR
  1. RANGEX Q
  1.  ;
  1. DUPCHK ;
  1.  S END=$L(X,","),BAD=0
  1.  F I=1:1:END S RXM=$P(X,",",I) I +RXM F J=I+1:1:END S DUP=$P(X,",",J) I DUP=RXM S $P(X,",",J)="" W !?5,*7,"Duplicate RX # ",RXM,"  was found in your list, ignoring it!",! S BAD=1
  1.  S Y=$P(X,",") F I=2:1:END S RXM=$P(X,",",I) S:RXM'?1.N.A BAD=1 I RXM?1.N.A S Y=Y_","_RXM
  1. BAD I BAD W !?15,"=> ",Y
  1.  I BAD W !,"Is this OKAY " S %=1 D YN^DICN I '% D QUES2 G BAD
  1.  I BAD,%'=1 S Y=""
  1.  K BAD
  1.  Q
  1.  ;
  1. PAT ; EP
  1.  S DIC=2,DIC(0)="QEAM" D ^DIC
  1.  I +Y'>0 G PATX
  1.  S PSODFN=+Y
  1. PATX ;
  1.  K X,Y,DIC,DA
  1.  Q
  1. EOJ ;
  1.  K BAD,X,PSONUM,DUP,RXM,DRG,GOOD,BAD,K,M,N
  1.  Q
  1.  ;
  1. QUES2 ;
  1.  W !!?5,"Enter 'YES' to take action on the list as displayed"
  1.  W !?5,"If you answer 'NO' you must re-enter the list"
  1.  Q
  1. QUES3 ;
  1.  W !!?5,"ENTER RX NUMBER OR A LIST OF RX NUMBERS SEPARATED BY COMMAS,"
  1.  W !?5,"e.g. 3233454A,3433434,3223322C"
  1.  W:$D(PSOFROM("PTLKUP")) !!?5,"Enter a 'P' to get a screen profile"
  1.  Q
  1.  ;