APSQDI1 ;IHS/ASDS/ENM/POC - LOOK UP CONTINUED FM APSQDI[ 05/25/2001 4:05 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;**3**;01/10/2001
EN1 ;
K APSQARR
S APSQCNT=0,APSQLKUP=""
;S APSQSEQ=0 F S APSQSEQ=$O(^APSQFA("S",APSQSEQ)) Q:APSQSEQ="" D
S:'$D(PSOSITE) PSOSITE=$O(^PS(59,"C",DUZ(2),"")) ;IF PSOSITE NOT SET MULTIPLE DIVISIONS IHS/OKCAO/POC 1/10/2001
S:'$O(^APSQFA("SD",PSOSITE,"")) VALMQUIT=1 ;QUIT IF NO ENTRIES IHS/OKCAO/POC 5/12/2001
S APSQSEQ=0 F S APSQSEQ=$O(^APSQFA("SD",PSOSITE,APSQSEQ)) Q:APSQSEQ="" D ;USE THE SD XREF MULTIPLE DIVISIONS 1/10/2001 IHS/OKCAO/POC
.S APSQLKUP=$$SETSTR^VALM1($J(APSQSEQ,2),APSQLKUP,3,3)
.;S APSQIEN=$O(^APSQFA("S",APSQSEQ,""))
.S APSQIEN=$O(^APSQFA("SD",PSOSITE,APSQSEQ,"")) ;USE THE SD XREF MULTIPLE DIVISIONS 1/10/2001 IHS/OKCAO/POC
.Q:'APSQIEN
.S APSQNAME=$P(^APSQFA(APSQIEN,0),U,1)
.S APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,15)
.;I $D(^APSQFA(APSQIEN,2))#10 S APSQSEC="EXPLODE"
.I $O(^APSQFA(APSQIEN,2,0)) S APSQSEC="EXPLODE"
.E S APSQSEC=$P(^PSDRUG($P(^APSQFA(APSQIEN,0),U,2),0),U,1)
.S APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,25,20)
.S APSQARR(APSQSEQ,0)=APSQLKUP
.S APSQCNT=APSQCNT+1
.S APSQARR("IDX",APSQCNT,APSQSEQ)=APSQIEN
.S APSQLKUP=""
.Q
;NEED TO SET VALMCNT=APSQCNT
Q
EN2 ;LOOK UP
K APSQARR
S (APSQCNT,APSQLKUP)="",(APSQLAST,APSQKILL)=0
;S APSQSEQ=0 F S APSQSEQ=$O(^APSQFA("S",APSQSEQ)) Q:APSQSEQ="" D
S:'$D(PSOSITE) PSOSITE=$O(^PS(59,"C",DUZ(2),"")) ;IF NOT SET MULTIPLE DIVISIONS IHS/OKCAO/POC 1/10/2001
S:'$O(^APSQFA("SD",PSOSITE,"")) VALMQUIT=1 ;QUIT IF NO ENTRIES IHS/OKCAO/POC 5/12/2001
S APSQSEQ=0 F S APSQSEQ=$O(^APSQFA("SD",PSOSITE,APSQSEQ)) Q:APSQSEQ="" D ;IHS/OKCAO/POC USE THIS NEW SD XREF TO GET ONLY DRUGS FOR THIS DIVISION MULTIPLE DIVISIONS1/10/2001
.;ADD THE NEXT TWO LINES TO SCREEN OUT ENTRIES NOT THIS DIVISION IHS/OKCAO/POC 1/10/2001
.;S APSQSEEN=$O(^APSQFA("SD",PSOSITE,APSQSEQ,""))
.;Q:$P(^APSQFA(APSQSEEN,0),U,10)'=PSOSITE
.D SUB1
.D SWT
.;S:'APSQKILL APSQCNT=APSQCNT+1
.D FILE:'APSQKILL
I APSQKILL S APSQLAST=1 D FILE ;FOR THE LAST ONE IF ODD
;D FILE2
Q
SUB1 ;S APSQSEQ=APSQSEQ+1
I $D(APSQ("GOT",APSQSEQ)) S APSQSTAR=1
;I 'APSQKILL S APSQLKUP=$$SETSTR^VALM1($J($S($G(APSQSTAR):"*",1:"")_APSQSEQ,2),APSQLKUP,3,3)
I 'APSQKILL S APSQLKUP=$$SETSTR^VALM1($J($S($G(APSQSTAR):"*",1:"")_APSQSEQ,4),APSQLKUP,3,4)
;I APSQKILL S APSQLKUP=$$SETSTR^VALM1($J($S($G(APSQSTAR):"*",1:"")_APSQSEQ,2),APSQLKUP,40,3)
I APSQKILL S APSQLKUP=$$SETSTR^VALM1($J($S($G(APSQSTAR):"*",1:"")_APSQSEQ,4),APSQLKUP,40,4)
K APSQSTAR
;S APSQIEN=$O(^APSQFA("S",APSQSEQ,""))
S APSQIEN=$O(^APSQFA("SD",PSOSITE,APSQSEQ,"")) ;USE THE SD XREF MULTIPLE DIVISIONS IHS/OKCAO/POC 1/10/2001
Q:'APSQIEN
S APSQNAME=$P(^APSQFA(APSQIEN,0),U,1)
I 'APSQKILL S APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,10)
I APSQKILL S APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,45,10)
;I $D(^APSQFA(APSQIEN,2))#10 S APSQSEC="EXPLODE"
I $O(^APSQFA(APSQIEN,2,0)) S APSQSEC="EXPLODE"
E S APSQSEC=$P(^PSDRUG($P(^APSQFA(APSQIEN,0),U,2),0),U,1)
I 'APSQKILL S APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,20,15)
I APSQKILL S APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,57,15)
Q
FILE ;
S APSQCNT=APSQCNT+1
;S APSQARR(APSQSEQ,0)=APSQLKUP
S APSQARR(APSQCNT,0)=APSQLKUP
S APSQLKUP=""
Q
;LINE BELOW FOR LAST ONE
I APSQLAST S APSQLAST=0 S APSQARR("TMP",APSQCNT)=(APSQCNT*2-1)
;THIS WHOLE SERIES OF LINES TO SET IDX IS TO GET AROUND ONE COLUMN
E S APSQARR("TMP",APSQCNT)=(APSQCNT*2-1)_","_(APSQCNT*2)
Q
FILE2 ;FIX IDX
S (I,IDX)=0 F S IDX=$O(APSQARR("TMP",IDX)) Q:IDX="" D
.S I=I+1
.;VALM("BM") IS THE BOTTOM MARGIN MUST BE 6!!! OR MUST CHANGE "4" BELOW
.S APSQBM=VALM("BM")-4 ;GOT FOUR LINES AT BEGINNING OF HEADING
.S APSQARR("IDX",IDX,$S((I=APSQBM)&$P(APSQARR("TMP",IDX),",",2):$P(APSQARR("TMP",IDX),",",2),1:$P(APSQARR("TMP",IDX),",",1)))=""
.I I=VALM("BM") S I=0
;NEED TO SET VALMCNT=APSQCNT
Q
SWT ;SWITH APSQKILL BACK AND FORTH BETWEEN 1 AND 0
;APSQKILL IS USED TO SET THE FIRST AND SECOND PART OF VARIABLE APSQLKUP
;AND SET A APSQARR("DIR",APSQSEQ,APSQIEN)=""
S APSQARR("DIR",APSQSEQ,APSQIEN)=""
I APSQKILL=1 S APSQKILL=0 Q
E S APSQKILL=1
Q
DEL ;DELETE ENTITIES
;
D FULL^VALM1
I '$D(APSQ("GOT")) W !,"YOU DONT HAVE ANY ENTRIES TO DELETE-BYE" D BACK Q
S APSQBEG=$O(APSQARR("DIR","")),APSQEND=$O(APSQARR("DIR",""),-1)
K DIR
S DIR(0)="LO^"_APSQBEG_":"_APSQEND
D ^DIR
I '+Y W !,"NO SELECTIONS-BYE" Q
S APSQY="" F S APSQY=$O(Y(APSQY)) Q:APSQY="" D
.F I=1:1 S APSQGOT=$P(Y(APSQY),",",I) Q:APSQGOT="" D
..S APSQGOTT=$O(APSQ("GOT",APSQGOT,""))
..I APSQGOTT="" W !,"NO SUCH CRITTER ",APSQGOT
..;E S APSQARR("GOT",APSQGOTT)=""
..;SO APSQ("GOT") IS THE ARRAY YOU CHOSE
..;E S APSQARR("GOT",APSQGOT,APSQGOTT)="",APSQ("GOT",APSQGOT,APSQGOTT)=""
..E S APSQARR("GOT",APSQGOT,APSQGOTT)="" ;FOR LIST BUT GETS DELETED AT ENTRY POINT EN?
..E K APSQ("GOT",APSQGOT,APSQGOTT)
D LIST,HANG,WIPE,EN2,BACK
Q
ADD ;SELECT ENTITIES
;D EN^VALM2(XQORNOD(0),"O") ;this list man call allows user to select an entry in list
;I '$D(VALMY) W !,"Nothing selected." Q
D FULL^VALM1 ;give me full control of screen
Q:'$D(APSQARR("DIR"))
S APSQBEG=$O(APSQARR("DIR","")),APSQEND=$O(APSQARR("DIR",""),-1)
K DIR
S DIR(0)="LO^"_APSQBEG_":"_APSQEND
D ^DIR
I '+Y W !,"NO SELECTIONS-BYE" Q
S APSQY="" F S APSQY=$O(Y(APSQY)) Q:APSQY="" D
.F I=1:1 S APSQGOT=$P(Y(APSQY),",",I) Q:APSQGOT="" D
..S APSQGOTT=$O(APSQARR("DIR",APSQGOT,""))
..I APSQGOTT="" W !,"NO SUCH CRITTER ",APSQGOT," SO ITEM DELETED!"
..;E S APSQARR("GOT",APSQGOTT)=""
..;SO APSQ("GOT") IS USED TO PUT STARS IN FRONT OF SEQUENCE
..;APSQARR IS FOR LIST BUT GETS DELETED AT EN? ENTRY POINT
..E S APSQARR("GOT",APSQGOT,APSQGOTT)="",APSQ("GOT",APSQGOT,APSQGOTT)=""
D LIST,HANG,SET,EN2,BACK
Q
HANG ;
K DIR
S DIR(0)="EO",DIR("A")="HIT RETURN TO CONTINUE..." D ^DIR K DIR
Q
LIST ;LIST ENTRIES SELECTED
W !,$S($D(APSQARR("GOT")):"",1:"NO ")," ENTRIES SELECTED:"
S APSQLIST=0 F S APSQLIST=$O(APSQARR("GOT",APSQLIST)) Q:APSQLIST="" D
.S APSQLIS1=$O(APSQARR("GOT",APSQLIST,""))
.W !,$P(^APSQFA(APSQLIS1,0),U,1)
Q
;
SET ;SET UP FOR NEXT PART
S APSQLIST=0 F S APSQLIST=$O(APSQ("GOT",APSQLIST)) Q:APSQLIST="" D
.S APSQLIS1=$O(APSQ("GOT",APSQLIST,""))
.I $O(^APSQFA(APSQLIS1,2,0)) D
..S APSQEXP=0 F S APSQEXP=$O(^APSQFA(APSQLIS1,2,APSQEXP)) Q:'+APSQEXP D ;
...S APSQEXP1=$P(^APSQFA(APSQLIS1,2,APSQEXP,0),U,1)
...I APSQEXP1 S DRUGPICK(APSQEXP1)=""
...;S APSQEXP2=$P(^APSQFA(APSQEXP1,0),U,2) ;S DRUG(APSQEXP1)=""
...;I APSQEXP2 S DRUG(APSQEXP2)=""
..K DRUGPICK(APSQLIS1)
.I '$O(^APSQFA(APSQLIS1,2,0)) I $P(^APSQFA(APSQLIS1,0),U,2) S DRUGPICK(APSQLIS1)=""
.;I $P(^APSQFA(APSQLIS1,0),U,2) S DRUG($P(^(0),U,2))=""
Q
BACK ;GO BACK
D TERM^VALM0
S VALMBCK="R"
;D INIT AGAIN
K DIR
Q
;
WIPE ;DELEETE ENTRIES FROM DRUG ARRAY USING APSQARR("GOT")
S APSQGOT=0 F S APSQGOT=$O(APSQARR("GOT",APSQGOT)) Q:APSQGOT="" D
.S APSQGOT1=$O(APSQARR("GOT",APSQGOT,""))
.I $O(^APSQFA(APSQGOT1,2,0)) D
..S DRUG=0 F S DRUG=$O(^APSQFA(APSQGOT1,2,DRUG)) Q:DRUG'=+DRUG D
...I DRUG S DRUG1=$P(^APSQFA(APSQGOT1,2,DRUG,0),U,1)
...;I DRUG1 K DRUG(DRUG1)
...I DRUG1 K DRUGPICK(DRUG1)
.;I $P(^APSQFA(APSQGOT1,0),U,2) K DRUG($P(^(0),U,2))
.I $P(^APSQFA(APSQGOT1,0),U,2) K DRUGPICK(APSQGOT1)
Q
APSQDI1 ;IHS/ASDS/ENM/POC - LOOK UP CONTINUED FM APSQDI[ 05/25/2001 4:05 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;01/10/2001
EN1 ;
+1 KILL APSQARR
+2 SET APSQCNT=0
SET APSQLKUP=""
+3 ;S APSQSEQ=0 F S APSQSEQ=$O(^APSQFA("S",APSQSEQ)) Q:APSQSEQ="" D
+4 ;IF PSOSITE NOT SET MULTIPLE DIVISIONS IHS/OKCAO/POC 1/10/2001
IF '$DATA(PSOSITE)
SET PSOSITE=$ORDER(^PS(59,"C",DUZ(2),""))
+5 ;QUIT IF NO ENTRIES IHS/OKCAO/POC 5/12/2001
IF '$ORDER(^APSQFA("SD",PSOSITE,""))
SET VALMQUIT=1
+6 ;USE THE SD XREF MULTIPLE DIVISIONS 1/10/2001 IHS/OKCAO/POC
SET APSQSEQ=0
FOR
SET APSQSEQ=$ORDER(^APSQFA("SD",PSOSITE,APSQSEQ))
IF APSQSEQ=""
QUIT
Begin DoDot:1
+7 SET APSQLKUP=$$SETSTR^VALM1($JUSTIFY(APSQSEQ,2),APSQLKUP,3,3)
+8 ;S APSQIEN=$O(^APSQFA("S",APSQSEQ,""))
+9 ;USE THE SD XREF MULTIPLE DIVISIONS 1/10/2001 IHS/OKCAO/POC
SET APSQIEN=$ORDER(^APSQFA("SD",PSOSITE,APSQSEQ,""))
+10 IF 'APSQIEN
QUIT
+11 SET APSQNAME=$PIECE(^APSQFA(APSQIEN,0),U,1)
+12 SET APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,15)
+13 ;I $D(^APSQFA(APSQIEN,2))#10 S APSQSEC="EXPLODE"
+14 IF $ORDER(^APSQFA(APSQIEN,2,0))
SET APSQSEC="EXPLODE"
+15 IF '$TEST
SET APSQSEC=$PIECE(^PSDRUG($PIECE(^APSQFA(APSQIEN,0),U,2),0),U,1)
+16 SET APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,25,20)
+17 SET APSQARR(APSQSEQ,0)=APSQLKUP
+18 SET APSQCNT=APSQCNT+1
+19 SET APSQARR("IDX",APSQCNT,APSQSEQ)=APSQIEN
+20 SET APSQLKUP=""
+21 QUIT
End DoDot:1
+22 ;NEED TO SET VALMCNT=APSQCNT
+23 QUIT
EN2 ;LOOK UP
+1 KILL APSQARR
+2 SET (APSQCNT,APSQLKUP)=""
SET (APSQLAST,APSQKILL)=0
+3 ;S APSQSEQ=0 F S APSQSEQ=$O(^APSQFA("S",APSQSEQ)) Q:APSQSEQ="" D
+4 ;IF NOT SET MULTIPLE DIVISIONS IHS/OKCAO/POC 1/10/2001
IF '$DATA(PSOSITE)
SET PSOSITE=$ORDER(^PS(59,"C",DUZ(2),""))
+5 ;QUIT IF NO ENTRIES IHS/OKCAO/POC 5/12/2001
IF '$ORDER(^APSQFA("SD",PSOSITE,""))
SET VALMQUIT=1
+6 ;IHS/OKCAO/POC USE THIS NEW SD XREF TO GET ONLY DRUGS FOR THIS DIVISION MULTIPLE DIVISIONS1/10/2001
SET APSQSEQ=0
FOR
SET APSQSEQ=$ORDER(^APSQFA("SD",PSOSITE,APSQSEQ))
IF APSQSEQ=""
QUIT
Begin DoDot:1
+7 ;ADD THE NEXT TWO LINES TO SCREEN OUT ENTRIES NOT THIS DIVISION IHS/OKCAO/POC 1/10/2001
+8 ;S APSQSEEN=$O(^APSQFA("SD",PSOSITE,APSQSEQ,""))
+9 ;Q:$P(^APSQFA(APSQSEEN,0),U,10)'=PSOSITE
+10 DO SUB1
+11 DO SWT
+12 ;S:'APSQKILL APSQCNT=APSQCNT+1
+13 IF 'APSQKILL
DO FILE
End DoDot:1
+14 ;FOR THE LAST ONE IF ODD
IF APSQKILL
SET APSQLAST=1
DO FILE
+15 ;D FILE2
+16 QUIT
SUB1 ;S APSQSEQ=APSQSEQ+1
+1 IF $DATA(APSQ("GOT",APSQSEQ))
SET APSQSTAR=1
+2 ;I 'APSQKILL S APSQLKUP=$$SETSTR^VALM1($J($S($G(APSQSTAR):"*",1:"")_APSQSEQ,2),APSQLKUP,3,3)
+3 IF 'APSQKILL
SET APSQLKUP=$$SETSTR^VALM1($JUSTIFY($SELECT($GET(APSQSTAR):"*",1:"")_APSQSEQ,4),APSQLKUP,3,4)
+4 ;I APSQKILL S APSQLKUP=$$SETSTR^VALM1($J($S($G(APSQSTAR):"*",1:"")_APSQSEQ,2),APSQLKUP,40,3)
+5 IF APSQKILL
SET APSQLKUP=$$SETSTR^VALM1($JUSTIFY($SELECT($GET(APSQSTAR):"*",1:"")_APSQSEQ,4),APSQLKUP,40,4)
+6 KILL APSQSTAR
+7 ;S APSQIEN=$O(^APSQFA("S",APSQSEQ,""))
+8 ;USE THE SD XREF MULTIPLE DIVISIONS IHS/OKCAO/POC 1/10/2001
SET APSQIEN=$ORDER(^APSQFA("SD",PSOSITE,APSQSEQ,""))
+9 IF 'APSQIEN
QUIT
+10 SET APSQNAME=$PIECE(^APSQFA(APSQIEN,0),U,1)
+11 IF 'APSQKILL
SET APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,10)
+12 IF APSQKILL
SET APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,45,10)
+13 ;I $D(^APSQFA(APSQIEN,2))#10 S APSQSEC="EXPLODE"
+14 IF $ORDER(^APSQFA(APSQIEN,2,0))
SET APSQSEC="EXPLODE"
+15 IF '$TEST
SET APSQSEC=$PIECE(^PSDRUG($PIECE(^APSQFA(APSQIEN,0),U,2),0),U,1)
+16 IF 'APSQKILL
SET APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,20,15)
+17 IF APSQKILL
SET APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,57,15)
+18 QUIT
FILE ;
+1 SET APSQCNT=APSQCNT+1
+2 ;S APSQARR(APSQSEQ,0)=APSQLKUP
+3 SET APSQARR(APSQCNT,0)=APSQLKUP
+4 SET APSQLKUP=""
+5 QUIT
+6 ;LINE BELOW FOR LAST ONE
+7 IF APSQLAST
SET APSQLAST=0
SET APSQARR("TMP",APSQCNT)=(APSQCNT*2-1)
+8 ;THIS WHOLE SERIES OF LINES TO SET IDX IS TO GET AROUND ONE COLUMN
+9 IF '$TEST
SET APSQARR("TMP",APSQCNT)=(APSQCNT*2-1)_","_(APSQCNT*2)
+10 QUIT
FILE2 ;FIX IDX
+1 SET (I,IDX)=0
FOR
SET IDX=$ORDER(APSQARR("TMP",IDX))
IF IDX=""
QUIT
Begin DoDot:1
+2 SET I=I+1
+3 ;VALM("BM") IS THE BOTTOM MARGIN MUST BE 6!!! OR MUST CHANGE "4" BELOW
+4 ;GOT FOUR LINES AT BEGINNING OF HEADING
SET APSQBM=VALM("BM")-4
+5 SET APSQARR("IDX",IDX,$SELECT((I=APSQBM)&$PIECE(APSQARR("TMP",IDX),",",2):$PIECE(APSQARR("TMP",IDX),",",2),1:$PIECE(APSQARR("TMP",IDX),",",1)))=""
+6 IF I=VALM("BM")
SET I=0
End DoDot:1
+7 ;NEED TO SET VALMCNT=APSQCNT
+8 QUIT
SWT ;SWITH APSQKILL BACK AND FORTH BETWEEN 1 AND 0
+1 ;APSQKILL IS USED TO SET THE FIRST AND SECOND PART OF VARIABLE APSQLKUP
+2 ;AND SET A APSQARR("DIR",APSQSEQ,APSQIEN)=""
+3 SET APSQARR("DIR",APSQSEQ,APSQIEN)=""
+4 IF APSQKILL=1
SET APSQKILL=0
QUIT
+5 IF '$TEST
SET APSQKILL=1
+6 QUIT
DEL ;DELETE ENTITIES
+1 ;
+2 DO FULL^VALM1
+3 IF '$DATA(APSQ("GOT"))
WRITE !,"YOU DONT HAVE ANY ENTRIES TO DELETE-BYE"
DO BACK
QUIT
+4 SET APSQBEG=$ORDER(APSQARR("DIR",""))
SET APSQEND=$ORDER(APSQARR("DIR",""),-1)
+5 KILL DIR
+6 SET DIR(0)="LO^"_APSQBEG_":"_APSQEND
+7 DO ^DIR
+8 IF '+Y
WRITE !,"NO SELECTIONS-BYE"
QUIT
+9 SET APSQY=""
FOR
SET APSQY=$ORDER(Y(APSQY))
IF APSQY=""
QUIT
Begin DoDot:1
+10 FOR I=1:1
SET APSQGOT=$PIECE(Y(APSQY),",",I)
IF APSQGOT=""
QUIT
Begin DoDot:2
+11 SET APSQGOTT=$ORDER(APSQ("GOT",APSQGOT,""))
+12 IF APSQGOTT=""
WRITE !,"NO SUCH CRITTER ",APSQGOT
+13 ;E S APSQARR("GOT",APSQGOTT)=""
+14 ;SO APSQ("GOT") IS THE ARRAY YOU CHOSE
+15 ;E S APSQARR("GOT",APSQGOT,APSQGOTT)="",APSQ("GOT",APSQGOT,APSQGOTT)=""
+16 ;FOR LIST BUT GETS DELETED AT ENTRY POINT EN?
IF '$TEST
SET APSQARR("GOT",APSQGOT,APSQGOTT)=""
+17 IF '$TEST
KILL APSQ("GOT",APSQGOT,APSQGOTT)
End DoDot:2
End DoDot:1
+18 DO LIST
DO HANG
DO WIPE
DO EN2
DO BACK
+19 QUIT
ADD ;SELECT ENTITIES
+1 ;D EN^VALM2(XQORNOD(0),"O") ;this list man call allows user to select an entry in list
+2 ;I '$D(VALMY) W !,"Nothing selected." Q
+3 ;give me full control of screen
DO FULL^VALM1
+4 IF '$DATA(APSQARR("DIR"))
QUIT
+5 SET APSQBEG=$ORDER(APSQARR("DIR",""))
SET APSQEND=$ORDER(APSQARR("DIR",""),-1)
+6 KILL DIR
+7 SET DIR(0)="LO^"_APSQBEG_":"_APSQEND
+8 DO ^DIR
+9 IF '+Y
WRITE !,"NO SELECTIONS-BYE"
QUIT
+10 SET APSQY=""
FOR
SET APSQY=$ORDER(Y(APSQY))
IF APSQY=""
QUIT
Begin DoDot:1
+11 FOR I=1:1
SET APSQGOT=$PIECE(Y(APSQY),",",I)
IF APSQGOT=""
QUIT
Begin DoDot:2
+12 SET APSQGOTT=$ORDER(APSQARR("DIR",APSQGOT,""))
+13 IF APSQGOTT=""
WRITE !,"NO SUCH CRITTER ",APSQGOT," SO ITEM DELETED!"
+14 ;E S APSQARR("GOT",APSQGOTT)=""
+15 ;SO APSQ("GOT") IS USED TO PUT STARS IN FRONT OF SEQUENCE
+16 ;APSQARR IS FOR LIST BUT GETS DELETED AT EN? ENTRY POINT
+17 IF '$TEST
SET APSQARR("GOT",APSQGOT,APSQGOTT)=""
SET APSQ("GOT",APSQGOT,APSQGOTT)=""
End DoDot:2
End DoDot:1
+18 DO LIST
DO HANG
DO SET
DO EN2
DO BACK
+19 QUIT
HANG ;
+1 KILL DIR
+2 SET DIR(0)="EO"
SET DIR("A")="HIT RETURN TO CONTINUE..."
DO ^DIR
KILL DIR
+3 QUIT
LIST ;LIST ENTRIES SELECTED
+1 WRITE !,$SELECT($DATA(APSQARR("GOT")):"",1:"NO ")," ENTRIES SELECTED:"
+2 SET APSQLIST=0
FOR
SET APSQLIST=$ORDER(APSQARR("GOT",APSQLIST))
IF APSQLIST=""
QUIT
Begin DoDot:1
+3 SET APSQLIS1=$ORDER(APSQARR("GOT",APSQLIST,""))
+4 WRITE !,$PIECE(^APSQFA(APSQLIS1,0),U,1)
End DoDot:1
+5 QUIT
+6 ;
SET ;SET UP FOR NEXT PART
+1 SET APSQLIST=0
FOR
SET APSQLIST=$ORDER(APSQ("GOT",APSQLIST))
IF APSQLIST=""
QUIT
Begin DoDot:1
+2 SET APSQLIS1=$ORDER(APSQ("GOT",APSQLIST,""))
+3 IF $ORDER(^APSQFA(APSQLIS1,2,0))
Begin DoDot:2
+4 ;
SET APSQEXP=0
FOR
SET APSQEXP=$ORDER(^APSQFA(APSQLIS1,2,APSQEXP))
IF '+APSQEXP
QUIT
Begin DoDot:3
+5 SET APSQEXP1=$PIECE(^APSQFA(APSQLIS1,2,APSQEXP,0),U,1)
+6 IF APSQEXP1
SET DRUGPICK(APSQEXP1)=""
+7 ;S APSQEXP2=$P(^APSQFA(APSQEXP1,0),U,2) ;S DRUG(APSQEXP1)=""
+8 ;I APSQEXP2 S DRUG(APSQEXP2)=""
End DoDot:3
+9 KILL DRUGPICK(APSQLIS1)
End DoDot:2
+10 IF '$ORDER(^APSQFA(APSQLIS1,2,0))
IF $PIECE(^APSQFA(APSQLIS1,0),U,2)
SET DRUGPICK(APSQLIS1)=""
+11 ;I $P(^APSQFA(APSQLIS1,0),U,2) S DRUG($P(^(0),U,2))=""
End DoDot:1
+12 QUIT
BACK ;GO BACK
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 ;D INIT AGAIN
+4 KILL DIR
+5 QUIT
+6 ;
WIPE ;DELEETE ENTRIES FROM DRUG ARRAY USING APSQARR("GOT")
+1 SET APSQGOT=0
FOR
SET APSQGOT=$ORDER(APSQARR("GOT",APSQGOT))
IF APSQGOT=""
QUIT
Begin DoDot:1
+2 SET APSQGOT1=$ORDER(APSQARR("GOT",APSQGOT,""))
+3 IF $ORDER(^APSQFA(APSQGOT1,2,0))
Begin DoDot:2
+4 SET DRUG=0
FOR
SET DRUG=$ORDER(^APSQFA(APSQGOT1,2,DRUG))
IF DRUG'=+DRUG
QUIT
Begin DoDot:3
+5 IF DRUG
SET DRUG1=$PIECE(^APSQFA(APSQGOT1,2,DRUG,0),U,1)
+6 ;I DRUG1 K DRUG(DRUG1)
+7 IF DRUG1
KILL DRUGPICK(DRUG1)
End DoDot:3
End DoDot:2
+8 ;I $P(^APSQFA(APSQGOT1,0),U,2) K DRUG($P(^(0),U,2))
+9 IF $PIECE(^APSQFA(APSQGOT1,0),U,2)
KILL DRUGPICK(APSQGOT1)
End DoDot:1
+10 QUIT
