- 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
