APSPRT1.m

APSPRT1 ; IHS/DSD/ENM - INITIALIZE PREPACK VARIABLES ;  [ 08/25/1999  2:59 PM ]

 ;;6.0;IHS PHARMACY MODIFICATIONS;**2**;09/03/97

START ;

 ;

 I '$D(%APSITE),$D(^APSPCTRL(PSOSITE,0)) S %APSITE=^(0) ;IHS/DSD/ENM 08/01/96

 I $P(%APSITE,U,16)'>1 W !,"You must first enter the IHS site parameters dealing with",!,"prepack label sizes and widths . Thank you" S APSPRT("QUIT")=1 G INITX

 I $P(%APSITE,U,22)'>2 W !,"You must first enter a Prepack Label Width under the IHS site parameters. Thank you" S APSPRT("QUIT")=1 G INITX

 F I=16:1:19 S APSP(I)=+$P(%APSITE,U,I)

 F I=21:1:28 S APSP(I)=+$P(%APSITE,U,I)

 S APSP(29)=$P(%APSITE,U,29)

 S APSP(31)=+$P(%APSITE,U,31)

 S APSP("LINE1")=$P(%APSITE,U,32)

 S APSP("LINE2")=$P(%APSITE,U,33)

 S %ZIS="N",%ZIS("A")="Prepack Label Printer : " D ^%ZIS

 K %ZIS

 S:POP=0 APSPRT("IO")=ION

 S:POP=1 APSPRT("QUIT")=1

 D EXPDATE ;Sets APSP("EXPDATE")=TODAY + 6 MONTHS

 S APSP("LASTP")=$S($D(^APSPP(31,"LAST")):$P(^APSPP(31,"LAST"),U,1),1:"")

 S APSP("LASTU")=$S($D(^APSPP(31,"LAST")):$P(^APSPP(31,"LAST"),U,2),1:"")

INITX ; Exit point for INIT subroutine

 Q

EXPDATE ;

 S X="T+6M" D ^%DT

 ;S APSP("EXPDATE")=$E(Y,4,5)_"/"_$E(Y,2,3)

 S APSP("EXPDATE")=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) ;IHS/DSD/ENM 07/14/99

 Q

EN ;EP

 ;

 S APSPGY="" F APSP=1:1:$L(APSP("SIG")," ") S X=$P(APSP("SIG")," ",APSP) S:X]"" APSPGY=APSPGY_X_" "

 S APSPS=1,APSPY=APSP(22)-2,APSPE=APSP(22)-1,APSPDR1=0

SIG1 F APSPF=APSPS:0:APSPY S APSPF=$F(APSPGY," ",APSPF) Q:'APSPF  I APSPF'>APSPY,$L(APSPGY)>(APSP(22)-3) S APSPE=APSPF

 S X=$E(APSPGY,APSPS,APSPE-2),APSPS=APSPE,APSPY=APSPS+APSP(22)-4,APSPDR1=APSPDR1+1,APSPGY(APSPDR1)=X

 G SIG1:APSPE<$L(APSPGY) S APSPGC=APSPDR1,APSPGY(APSPDR1)=APSPGY(APSPDR1)_"."

 I $L(APSP("DRUG"))+$L(APSP("QTY"))+3>APSP(22) D SIG2

 K APSP("SIG"),APSPE,APSPF,APSPS,APSPY

 Q

SIG2 ;

 I $L(APSP("QTY"))+$L(APSPGY(APSPGC))+1<APSP(22) S APSPGY(APSPGC)=APSPGY(APSPGC)_$E("           ",1,APSP(22)-$L(APSP("QTY"))-$L(APSPGY(APSPGC))-2)_APSP("QTY") S APSP("QTYFLG")=""

 I '$D(APSP("QTYFLG")) S APSPGC=APSPGC+1,APSPGY(APSPGC)=APSP("QTY") S APSP("QTYFLG")=""

 Q

APSPRT1   ; IHS/DSD/ENM - INITIALIZE PREPACK VARIABLES ;  [ 08/25/1999  2:59 PM ]

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;**2**;09/03/97

START     ;

 +1       ;

 +2       ;IHS/DSD/ENM 08/01/96

           IF '$DATA(%APSITE)

               IF $DATA(^APSPCTRL(PSOSITE,0))

                   SET %APSITE=^(0)

 +3        IF $PIECE(%APSITE,U,16)'>1

               WRITE !,"You must first enter the IHS site parameters dealing with",!,"prepack label sizes and widths . Thank you"

               SET APSPRT("QUIT")=1

               GOTO INITX

 +4        IF $PIECE(%APSITE,U,22)'>2

               WRITE !,"You must first enter a Prepack Label Width under the IHS site parameters. Thank you"

               SET APSPRT("QUIT")=1

               GOTO INITX

 +5        FOR I=16:1:19

               SET APSP(I)=+$PIECE(%APSITE,U,I)

 +6        FOR I=21:1:28

               SET APSP(I)=+$PIECE(%APSITE,U,I)

 +7        SET APSP(29)=$PIECE(%APSITE,U,29)

 +8        SET APSP(31)=+$PIECE(%APSITE,U,31)

 +9        SET APSP("LINE1")=$PIECE(%APSITE,U,32)

 +10       SET APSP("LINE2")=$PIECE(%APSITE,U,33)

 +11       SET %ZIS="N"

           SET %ZIS("A")="Prepack Label Printer : "

           DO ^%ZIS

 +12       KILL %ZIS

 +13       IF POP=0

               SET APSPRT("IO")=ION

 +14       IF POP=1

               SET APSPRT("QUIT")=1

 +15      ;Sets APSP("EXPDATE")=TODAY + 6 MONTHS

           DO EXPDATE

 +16       SET APSP("LASTP")=$SELECT($DATA(^APSPP(31,"LAST")):$PIECE(^APSPP(31,"LAST"),U,1),1:"")

 +17       SET APSP("LASTU")=$SELECT($DATA(^APSPP(31,"LAST")):$PIECE(^APSPP(31,"LAST"),U,2),1:"")

INITX     ; Exit point for INIT subroutine

 +1        QUIT 

EXPDATE   ;

 +1        SET X="T+6M"

           DO ^%DT

 +2       ;S APSP("EXPDATE")=$E(Y,4,5)_"/"_$E(Y,2,3)

 +3       ;IHS/DSD/ENM 07/14/99

           SET APSP("EXPDATE")=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)

 +4        QUIT 

EN        ;EP

 +1       ;

 +2        SET APSPGY=""

           FOR APSP=1:1:$LENGTH(APSP("SIG")," ")

               SET X=$PIECE(APSP("SIG")," ",APSP)

               IF X]""

                   SET APSPGY=APSPGY_X_" "

 +3        SET APSPS=1

           SET APSPY=APSP(22)-2

           SET APSPE=APSP(22)-1

           SET APSPDR1=0

SIG1       FOR APSPF=APSPS:0:APSPY

               SET APSPF=$FIND(APSPGY," ",APSPF)

               IF 'APSPF

                   QUIT 

               IF APSPF'>APSPY

                   IF $LENGTH(APSPGY)>(APSP(22)-3)

                       SET APSPE=APSPF

 +1        SET X=$EXTRACT(APSPGY,APSPS,APSPE-2)

           SET APSPS=APSPE

           SET APSPY=APSPS+APSP(22)-4

           SET APSPDR1=APSPDR1+1

           SET APSPGY(APSPDR1)=X

 +2        IF APSPE<$LENGTH(APSPGY)

               GOTO SIG1

           SET APSPGC=APSPDR1

           SET APSPGY(APSPDR1)=APSPGY(APSPDR1)_"."

 +3        IF $LENGTH(APSP("DRUG"))+$LENGTH(APSP("QTY"))+3>APSP(22)

               DO SIG2

 +4        KILL APSP("SIG"),APSPE,APSPF,APSPS,APSPY

 +5        QUIT 

SIG2      ;

 +1        IF $LENGTH(APSP("QTY"))+$LENGTH(APSPGY(APSPGC))+1<APSP(22)

               SET APSPGY(APSPGC)=APSPGY(APSPGC)_$EXTRACT("           ",1,APSP(22)-$LENGTH(APSP("QTY"))-$LENGTH(APSPGY(APSPGC))-2)_APSP("QTY")

               SET APSP("QTYFLG")=""

 +2        IF '$DATA(APSP("QTYFLG"))

               SET APSPGC=APSPGC+1

               SET APSPGY(APSPGC)=APSP("QTY")

               SET APSP("QTYFLG")=""

 +3        QUIT