APSQDISP.m

APSQDISP ;IHS/ASDS/ENM/POC - LOOK UP 

 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001

EN1 ;EP

 K APSQARR

 S APSQCNT=0,APSQLKUP=""

 S APSQSEQ=0 F  S APSQSEQ=$O(^APSQFAST("S",APSQSEQ)) Q:APSQSEQ=""   D

 .S APSQLKUP=$$SETSTR^VALM1($J(APSQSEQ,2),APSQLKUP,3,3)

 .S APSQIEN=$O(^APSQFAST("S",APSQSEQ,""))

 .Q:'APSQIEN

 .S APSQNAME=$P(^APSQFAST(APSQIEN,0),U,1)

 .S APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,15)

 .;I $D(^APSQFAST(APSQIEN,2))#10 S APSQSEC="EXPLODE"

 .I $O(^APSQFAST(APSQIEN,2,0)) S APSQSEC="EXPLODE"

 .E  S APSQSEC=$P(^PSDRUG($P(^APSQFAST(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 [ 12/06/98  7:08 PM ]

 K APSQARR

 S (APSQCNT,APSQLKUP)="",(APSQLAST,APSQKILL)=0

 S APSQSEQ=0 F  S APSQSEQ=$O(^APSQFAST("S",APSQSEQ)) Q:APSQSEQ=""   D  ;

 .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,2),APSQLKUP,40,3)

 K APSQSTAR

 S APSQIEN=$O(^APSQFAST("S",APSQSEQ,""))

 Q:'APSQIEN

 S APSQNAME=$P(^APSQFAST(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(^APSQFAST(APSQIEN,2))#10 S APSQSEC="EXPLODE"

 I $O(^APSQFAST(APSQIEN,2,0)) S APSQSEC="EXPLODE"

 E  S APSQSEC=$P(^PSDRUG($P(^APSQFAST(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

SELECT ;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)=""

 ..E  S APSQARR("GOT",APSQGOT,APSQGOTT)="",APSQ("GOT",APSQGOT,APSQGOTT)=""

 D LIST,HANG,EN2,BACK

 Q

HANG ;

 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(^APSQFAST(APSQLIS1,0),U,1)

 Q

BACK ;GO BACK

 D TERM^VALM0

 S VALMBCK="R"

 ;D INIT AGAIN

 K DIR

 Q

APSQDISP  ;IHS/ASDS/ENM/POC - LOOK UP 

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001

EN1       ;EP

 +1        KILL APSQARR

 +2        SET APSQCNT=0

           SET APSQLKUP=""

 +3        SET APSQSEQ=0

           FOR 

               SET APSQSEQ=$ORDER(^APSQFAST("S",APSQSEQ))

               IF APSQSEQ=""

                   QUIT 

               Begin DoDot:1

 +4                SET APSQLKUP=$$SETSTR^VALM1($JUSTIFY(APSQSEQ,2),APSQLKUP,3,3)

 +5                SET APSQIEN=$ORDER(^APSQFAST("S",APSQSEQ,""))

 +6                IF 'APSQIEN

                       QUIT 

 +7                SET APSQNAME=$PIECE(^APSQFAST(APSQIEN,0),U,1)

 +8                SET APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,15)

 +9       ;I $D(^APSQFAST(APSQIEN,2))#10 S APSQSEC="EXPLODE"

 +10               IF $ORDER(^APSQFAST(APSQIEN,2,0))

                       SET APSQSEC="EXPLODE"

 +11              IF '$TEST

                       SET APSQSEC=$PIECE(^PSDRUG($PIECE(^APSQFAST(APSQIEN,0),U,2),0),U,1)

 +12               SET APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,25,20)

 +13               SET APSQARR(APSQSEQ,0)=APSQLKUP

 +14               SET APSQCNT=APSQCNT+1

 +15               SET APSQARR("IDX",APSQCNT,APSQSEQ)=APSQIEN

 +16               SET APSQLKUP=""

 +17               QUIT 

               End DoDot:1

 +18      ;NEED TO SET VALMCNT=APSQCNT

 +19       QUIT 

EN2       ;LOOK UP [ 12/06/98  7:08 PM ]

 +1        KILL APSQARR

 +2        SET (APSQCNT,APSQLKUP)=""

           SET (APSQLAST,APSQKILL)=0

 +3       ;

           SET APSQSEQ=0

           FOR 

               SET APSQSEQ=$ORDER(^APSQFAST("S",APSQSEQ))

               IF APSQSEQ=""

                   QUIT 

               Begin DoDot:1

 +4                DO SUB1

 +5                DO SWT

 +6       ;S:'APSQKILL APSQCNT=APSQCNT+1

 +7                IF 'APSQKILL

                       DO FILE

               End DoDot:1

 +8       ;FOR THE LAST ONE IF ODD

           IF APSQKILL

               SET APSQLAST=1

               DO FILE

 +9       ;D FILE2

 +10       QUIT 

SUB1      ;S APSQSEQ=APSQSEQ+1

 +1        IF $DATA(APSQ("GOT",APSQSEQ))

               SET APSQSTAR=1

 +2        IF 'APSQKILL

               SET APSQLKUP=$$SETSTR^VALM1($JUSTIFY($SELECT($GET(APSQSTAR):"*",1:"")_APSQSEQ,2),APSQLKUP,3,3)

 +3        IF APSQKILL

               SET APSQLKUP=$$SETSTR^VALM1($JUSTIFY($SELECT($GET(APSQSTAR):"*",1:"")_APSQSEQ,2),APSQLKUP,40,3)

 +4        KILL APSQSTAR

 +5        SET APSQIEN=$ORDER(^APSQFAST("S",APSQSEQ,""))

 +6        IF 'APSQIEN

               QUIT 

 +7        SET APSQNAME=$PIECE(^APSQFAST(APSQIEN,0),U,1)

 +8        IF 'APSQKILL

               SET APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,8,10)

 +9        IF APSQKILL

               SET APSQLKUP=$$SETSTR^VALM1(APSQNAME,APSQLKUP,45,10)

 +10      ;I $D(^APSQFAST(APSQIEN,2))#10 S APSQSEC="EXPLODE"

 +11       IF $ORDER(^APSQFAST(APSQIEN,2,0))

               SET APSQSEC="EXPLODE"

 +12      IF '$TEST

               SET APSQSEC=$PIECE(^PSDRUG($PIECE(^APSQFAST(APSQIEN,0),U,2),0),U,1)

 +13       IF 'APSQKILL

               SET APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,20,15)

 +14       IF APSQKILL

               SET APSQLKUP=$$SETSTR^VALM1(APSQSEC,APSQLKUP,57,15)

 +15       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 

SELECT    ;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                      IF '$TEST

                               SET APSQARR("GOT",APSQGOT,APSQGOTT)=""

                               SET APSQ("GOT",APSQGOT,APSQGOTT)=""

                       End DoDot:2

               End DoDot:1

 +16       DO LIST

           DO HANG

           DO EN2

           DO BACK

 +17       QUIT 

HANG      ;

 +1        SET DIR(0)="EO"

           SET DIR("A")="HIT RETURN TO CONTINUE..."

           DO ^DIR

           KILL DIR

 +2        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(^APSQFAST(APSQLIS1,0),U,1)

               End DoDot:1

 +5        QUIT 

BACK      ;GO BACK

 +1        DO TERM^VALM0

 +2        SET VALMBCK="R"

 +3       ;D INIT AGAIN

 +4        KILL DIR

 +5        QUIT