APSPLIST ;BHAM/ISC/JCM - LIST OF NUMBERS READER [ 02/20/2001 3:38 PM ];21-Mar-2004 20:35;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**3**;09/03/97
; Copied from v6.0 PSOLIST - PSOLIST is not delivered with 7.0
; Modified - IHS/CIA/PLS - 02/15/04
;requires PSOHI, optionally PSOLO
;returns Y array
I $G(APSPID)]"" D ENMDT Q ;IHS/DSD/ENM 5.1.95 APSPID FM APSPSLBL
ASK S:'$D(PSOLO) PSOLO=1 S Y=""
W !,$S($G(PSONUM("A"))]"":PSONUM("A"),1:"Select ")_PSOLO_" - "_PSOHI_" > "
R X:DTIME
I '$T!(X["^") S PSOQFLG=1 K PSOLIST Q
I X["." W !,"WHAT'S WITH THE DOTS!!" G ASK ;IHS/OKCAO/POC 06/10/98
I X="" S:'$D(PSORX("BAR CODE")) PSOQFLG=1 K:'$D(PSORX("BAR CODE")) PSOLIST Q
S:X="ALL" X=PSOLO_":"_PSOHI
I X="" S Y="" G EXIT
I "Pp"[$E(X),$D(PSOSD) D ^PSODSPL G ASK
I "Rr"[$E(X) D GMRA^PSODEM G ASK
I X["?" D QUES G ASK
I X["-" D BARCODE^APSPNUM G ASK
G:$G(PSORX("BAR CODE"))]"" EXIT
L ; LIST OR RANGE
S Y(1)="",PSOC=1,PSOERR=0 S:'$D(PSOLO) PSOLO=1
;D DUPCHK F PSOI=1:1 S PSOX=$P(X,",",PSOI) Q:PSOERR!'$L($P(X,",",PSOI,999)) S:PSOX'?.".".N.".".":".N.":".N.".".N PSOERR=1 D L0:'PSOERR
F PSOI=1:1 S PSOX=$P(X,",",PSOI) Q:PSOERR!'$L($P(X,",",PSOI,999)) S:PSOX'?.".".N.".".":".N.":".N.".".N PSOERR=1 D L0:'PSOERR ;IHS/OKCAO/POC DO DUP CHECK LATER
D DUPCHK ;DO DUPCHK NOW IHS/OKCAO/POC
I PSOERR W !!?5,"Response should be no less than "_+PSOLO_" and no greater than "_PSOHI G ASK
S Y=Y(1) K PSO
EXIT K DUP,PSO,PSOA,PSOI,PSOLO,PSOHI,PSOX,PSOC,PSOJ
Q
L0 S:+PSOX<PSOLO!(PSOX>PSOHI) PSOERR=2 S PSO=$P(PSOX,":",2) I PSO,PSO>PSOHI!(PSO<PSOX) S PSOERR=3
Q:PSOERR I PSOX?.N!(PSOX?1N.".".N) S PSOJ=PSOX G L1
I PSOX#1 S Y(PSOC)=Y(PSOC)_+PSOX_",",$P(PSOX,":")=PSOX\1+1
F PSOJ=$P(PSOX,":"):1:$P(PSOX,":",2) D L1
I $P(PSOX,":",2)#1>0 S Y(PSOC)=Y(PSOC)_$P(PSOX,":",2)_","
Q
L1 I $L(Y(PSOC)_PSOJ)>220 S PSOC=PSOC+1,Y(PSOC)=""
F PSO=1:1:PSOC I Y(PSO)_","[(","_PSOJ_",") S PSO=-1 Q
I PSO'<0 S Y=PSOJ S Y(PSOC)=Y(PSOC)_PSOJ_","
Q
;
QUES W !!?5,"Enter a number, or a list of numbers sperated by commas,"
W !?5,"or a range of numbers seperated by a semicolon."
W !!?5,"Examples:"
W !!?5,"1,4,6,7",!?5,"3,5:9,2"
W !?5,"'ALL' (to select all)"
W !?5,"'R' to list allergies/adverse reactions"
I $D(PSOSD) W !?5,"'P' (to see profile)",!
Q
DUPCHK ;ADD NEXT LINE
N X S X=Y(1) ;ADDED IHS/OKCAO/POC
S END=$L(X,","),BAD=0
W ! 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 # "_RXM_" was found in your list, ignoring it!" S BAD=1
S DUP=$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 DUP=DUP_","_RXM
BAD I BAD W !!?15,"=> "_DUP,!,"Is this OKAY " S %=1 D YN^DICN I '% D QUES2^APSPNUM G BAD
I BAD,%'=1 S DUP="",PSOERR=1
S:DUP]"" X=DUP K BAD,RNM,DUP,%,END
Q
ENMDT ;IHS/DSD/ENM 5.1.95 DATE ORDER SETUP
S %DT("A")="Select Date: ",%DT="AEXP" D ^%DT S APSPBDT=Y-1,APSPEDT=Y ;IHS/DSD/ENM 01/29/96 'P' ADDED TO %DT
I APSPEDT=-1 W !,"No date selected so I'm quitting!!",! Q
S Y(1)="",Y=0
S APSPK="",APSPL="" F APSPK=APSPBDT:0 S APSPK=$O(APSPZDT(APSPK)) Q:'APSPK!(APSPK>APSPEDT) F S APSPL=$O(APSPZDT(APSPK,APSPL)) Q:'APSPL D ESET
Q
ESET S Y(1)=Y(1)_APSPL_",",Y=Y+1
Q
APSPLIST ;BHAM/ISC/JCM - LIST OF NUMBERS READER [ 02/20/2001 3:38 PM ];21-Mar-2004 20:35;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**3**;09/03/97
+2 ; Copied from v6.0 PSOLIST - PSOLIST is not delivered with 7.0
+3 ; Modified - IHS/CIA/PLS - 02/15/04
+4 ;requires PSOHI, optionally PSOLO
+5 ;returns Y array
+6 ;IHS/DSD/ENM 5.1.95 APSPID FM APSPSLBL
IF $GET(APSPID)]""
DO ENMDT
QUIT
ASK IF '$DATA(PSOLO)
SET PSOLO=1
SET Y=""
+1 WRITE !,$SELECT($GET(PSONUM("A"))]"":PSONUM("A"),1:"Select ")_PSOLO_" - "_PSOHI_" > "
+2 READ X:DTIME
+3 IF '$TEST!(X["^")
SET PSOQFLG=1
KILL PSOLIST
QUIT
+4 ;IHS/OKCAO/POC 06/10/98
IF X["."
WRITE !,"WHAT'S WITH THE DOTS!!"
GOTO ASK
+5 IF X=""
IF '$DATA(PSORX("BAR CODE"))
SET PSOQFLG=1
IF '$DATA(PSORX("BAR CODE"))
KILL PSOLIST
QUIT
+6 IF X="ALL"
SET X=PSOLO_":"_PSOHI
+7 IF X=""
SET Y=""
GOTO EXIT
+8 IF "Pp"[$EXTRACT(X)
IF $DATA(PSOSD)
DO ^PSODSPL
GOTO ASK
+9 IF "Rr"[$EXTRACT(X)
DO GMRA^PSODEM
GOTO ASK
+10 IF X["?"
DO QUES
GOTO ASK
+11 IF X["-"
DO BARCODE^APSPNUM
GOTO ASK
+12 IF $GET(PSORX("BAR CODE"))]""
GOTO EXIT
L ; LIST OR RANGE
+1 SET Y(1)=""
SET PSOC=1
SET PSOERR=0
IF '$DATA(PSOLO)
SET PSOLO=1
+2 ;D DUPCHK F PSOI=1:1 S PSOX=$P(X,",",PSOI) Q:PSOERR!'$L($P(X,",",PSOI,999)) S:PSOX'?.".".N.".".":".N.":".N.".".N PSOERR=1 D L0:'PSOERR
+3 ;IHS/OKCAO/POC DO DUP CHECK LATER
FOR PSOI=1:1
SET PSOX=$PIECE(X,",",PSOI)
IF PSOERR!'$LENGTH($PIECE(X,",",PSOI,999))
QUIT
IF PSOX'?.".".N."."."
SET PSOERR=1
IF 'PSOERR
DO L0
+4 ;DO DUPCHK NOW IHS/OKCAO/POC
DO DUPCHK
+5 IF PSOERR
WRITE !!?5,"Response should be no less than "_+PSOLO_" and no greater than "_PSOHI
GOTO ASK
+6 SET Y=Y(1)
KILL PSO
EXIT KILL DUP,PSO,PSOA,PSOI,PSOLO,PSOHI,PSOX,PSOC,PSOJ
+1 QUIT
L0 IF +PSOX<PSOLO!(PSOX>PSOHI)
SET PSOERR=2
SET PSO=$PIECE(PSOX,":",2)
IF PSO
IF PSO>PSOHI!(PSO<PSOX)
SET PSOERR=3
+1 IF PSOERR
QUIT
IF PSOX?.N!(PSOX?1N.".".N)
SET PSOJ=PSOX
GOTO L1
+2 IF PSOX#1
SET Y(PSOC)=Y(PSOC)_+PSOX_","
SET $PIECE(PSOX,":")=PSOX\1+1
+3 FOR PSOJ=$PIECE(PSOX,":"):1:$PIECE(PSOX,":",2)
DO L1
+4 IF $PIECE(PSOX,":",2)#1>0
SET Y(PSOC)=Y(PSOC)_$PIECE(PSOX,":",2)_","
+5 QUIT
L1 IF $LENGTH(Y(PSOC)_PSOJ)>220
SET PSOC=PSOC+1
SET Y(PSOC)=""
+1 FOR PSO=1:1:PSOC
IF Y(PSO)_","[(","_PSOJ_",")
SET PSO=-1
QUIT
+2 IF PSO'<0
SET Y=PSOJ
SET Y(PSOC)=Y(PSOC)_PSOJ_","
+3 QUIT
+4 ;
QUES WRITE !!?5,"Enter a number, or a list of numbers sperated by commas,"
+1 WRITE !?5,"or a range of numbers seperated by a semicolon."
+2 WRITE !!?5,"Examples:"
+3 WRITE !!?5,"1,4,6,7",!?5,"3,5:9,2"
+4 WRITE !?5,"'ALL' (to select all)"
+5 WRITE !?5,"'R' to list allergies/adverse reactions"
+6 IF $DATA(PSOSD)
WRITE !?5,"'P' (to see profile)",!
+7 QUIT
DUPCHK ;ADD NEXT LINE
+1 ;ADDED IHS/OKCAO/POC
NEW X
SET X=Y(1)
+2 SET END=$LENGTH(X,",")
SET BAD=0
+3 WRITE !
FOR I=1:1:END
SET RXM=$PIECE(X,",",I)
IF +RXM
FOR J=I+1:1:END
SET DUP=$PIECE(X,",",J)
IF DUP=RXM
SET $PIECE(X,",",J)=""
WRITE !?5,*7,"Duplicate # "_RXM_" was found in your list, ignoring it!"
SET BAD=1
+4 SET DUP=$PIECE(X,",")
FOR I=2:1:END
SET RXM=$PIECE(X,",",I)
IF RXM'?1.N.A
SET BAD=1
IF RXM?1.N.A
SET DUP=DUP_","_RXM
BAD IF BAD
WRITE !!?15,"=> "_DUP,!,"Is this OKAY "
SET %=1
DO YN^DICN
IF '%
DO QUES2^APSPNUM
GOTO BAD
+1 IF BAD
IF %'=1
SET DUP=""
SET PSOERR=1
+2 IF DUP]""
SET X=DUP
KILL BAD,RNM,DUP,%,END
+3 QUIT
ENMDT ;IHS/DSD/ENM 5.1.95 DATE ORDER SETUP
+1 ;IHS/DSD/ENM 01/29/96 'P' ADDED TO %DT
SET %DT("A")="Select Date: "
SET %DT="AEXP"
DO ^%DT
SET APSPBDT=Y-1
SET APSPEDT=Y
+2 IF APSPEDT=-1
WRITE !,"No date selected so I'm quitting!!",!
QUIT
+3 SET Y(1)=""
SET Y=0
+4 SET APSPK=""
SET APSPL=""
FOR APSPK=APSPBDT:0
SET APSPK=$ORDER(APSPZDT(APSPK))
IF 'APSPK!(APSPK>APSPEDT)
QUIT
FOR
SET APSPL=$ORDER(APSPZDT(APSPK,APSPL))
IF 'APSPL
QUIT
DO ESET
+5 QUIT
ESET SET Y(1)=Y(1)_APSPL_","
SET Y=Y+1
+1 QUIT
