PRCTLAB.m

PRCTLAB ;WISC@ALTOONA/RGY-GENERIC BARCODE LABEL ;10.21.98

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 SET DIC="^PRCT(446.5,",DIC(0)="QEAM" DO ^DIC GOTO:Y<0 Q1 SET PRCT=+Y,X=$PIECE(^PRCT(446.5,PRCT,0),"^",3) IF X]"" GOTO @($PIECE(X,"-")_"^"_$PIECE(X,"-",2))

EN ;Entry point, needs PRCT or optional BY, IOP, FR, TO, PRCTCPY, PRCTSR

 GOTO:'$DATA(PRCT) Q1 IF '$ORDER(^PRCT(446.5,PRCT,3,0)) WRITE *7," ... Report needs to be compiled!",! GOTO Q1

 SET:$PIECE(^PRCT(446.5,PRCT,0),"^",2) PRCTCPY=1

 SET DIC=$SELECT(+$PIECE(^PRCT(446.5,PRCT,0),"^",2):^DIC($PIECE(^(0),"^",2),0,"GL"),1:1),FLDS="S X=""""",L=0,DHD="@" SET:DIC DIC="^PRCT(446.5,",FR=PRCT,TO=PRCT,BY="@NUMBER",PRCTSR=0

 IF '$DATA(PRCTCPY) SET X="How many copies of each label do you want ?^1^^^COPY^PRCTMES2^QUX?.N&(QUX>0)&(QUX<1001)" DO ^PRCTQUES SET PRCTCPY=X

 GOTO:'PRCTCPY Q1 SET PRCTCPY=+PRCTCPY IF '$DATA(PRCTSR) SET X="Do you want to SEARCH the "_$PIECE(@(DIC_"0)"),"^")_" file before sorting (Y/N)? ^N^^^SP^PRCTMES2" DO ENYN^PRCTQUES GOTO:X="^" Q1 SET PRCTSR=X

 SET X=0 FOR Y=1:1 SET X=$ORDER(^PRCT(446.5,+PRCT,3,X)) QUIT:'X  SET FLDS(Y)=^(X,0)

 IF PRCTSR DO EN^DIS GOTO Q1

 DO EN1^DIP

Q1 KILL PRCTSC,PRCT,PRCTX,PRCTCP,PRCTCPY,PRCTSR,PRCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC,%T,ZTSK QUIT

XEC SET X="" XECUTE:$DATA(^PRCT(446.5,+PRCT,4,$PIECE(PRCT,"^",2),0)) ^(0) KILL PRCT WRITE X QUIT

SPC ;Call for executing specialty commands

 FOR X=0:0 SET X=$ORDER(^PRCT(446.6,+PRCT,$PIECE(PRCT,"^",2),X)) QUIT:'X  IF $DATA(^(X,0)),";"'[$EXTRACT(^(0)) WRITE @^(0)

 KILL PRCT SET X="" QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCTLAB   1600     printed  Apr 09, 2024@21:19:41                                                                                                                                                                                                     Page 2

PRCTLAB   ;WISC@ALTOONA/RGY-GENERIC BARCODE LABEL ;10.21.98

 +1       ;;5.1;IFCAP;;Oct 20, 2000

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        SET DIC="^PRCT(446.5,"

           SET DIC(0)="QEAM"

           DO ^DIC

           if Y<0

               GOTO Q1

           SET PRCT=+Y

           SET X=$PIECE(^PRCT(446.5,PRCT,0),"^",3)

           IF X]""

               GOTO @($PIECE(X,"-")_"^"_$PIECE(X,"-",2))

EN        ;Entry point, needs PRCT or optional BY, IOP, FR, TO, PRCTCPY, PRCTSR

 +1        if '$DATA(PRCT)

               GOTO Q1

           IF '$ORDER(^PRCT(446.5,PRCT,3,0))

               WRITE *7," ... Report needs to be compiled!",!

               GOTO Q1

 +2        if $PIECE(^PRCT(446.5,PRCT,0),"^",2)

               SET PRCTCPY=1

 +3        SET DIC=$SELECT(+$PIECE(^PRCT(446.5,PRCT,0),"^",2):^DIC($PIECE(^(0),"^",2),0,"GL"),1:1)

           SET FLDS="S X="""""

           SET L=0

           SET DHD="@"

           if DIC

               SET DIC="^PRCT(446.5,"

               SET FR=PRCT

               SET TO=PRCT

               SET BY="@NUMBER"

               SET PRCTSR=0

 +4        IF '$DATA(PRCTCPY)

               SET X="How many copies of each label do you want ?^1^^^COPY^PRCTMES2^QUX?.N&(QUX>0)&(QUX<1001)"

               DO ^PRCTQUES

               SET PRCTCPY=X

 +5        if 'PRCTCPY

               GOTO Q1

           SET PRCTCPY=+PRCTCPY

           IF '$DATA(PRCTSR)

               SET X="Do you want to SEARCH the "_$PIECE(@(DIC_"0)"),"^")_" file before sorting (Y/N)? ^N^^^SP^PRCTMES2"

               DO ENYN^PRCTQUES

               if X="^"

                   GOTO Q1

               SET PRCTSR=X

 +6        SET X=0

           FOR Y=1:1

               SET X=$ORDER(^PRCT(446.5,+PRCT,3,X))

               if 'X

                   QUIT 

               SET FLDS(Y)=^(X,0)

 +7        IF PRCTSR

               DO EN^DIS

               GOTO Q1

 +8        DO EN1^DIP

Q1         KILL PRCTSC,PRCT,PRCTX,PRCTCP,PRCTCPY,PRCTSR,PRCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC,%T,ZTSK

           QUIT 

XEC        SET X=""

           if $DATA(^PRCT(446.5,+PRCT,4,$PIECE(PRCT,"^",2),0))

               XECUTE ^(0)

           KILL PRCT

           WRITE X

           QUIT 

SPC       ;Call for executing specialty commands

 +1        FOR X=0:0

               SET X=$ORDER(^PRCT(446.6,+PRCT,$PIECE(PRCT,"^",2),X))

               if 'X

                   QUIT 

               IF $DATA(^(X,0))

                   IF ";"'[$EXTRACT(^(0))

                       WRITE @^(0)

 +2        KILL PRCT

           SET X=""

           QUIT