- 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 ---[H[J[2J[HPRCTLAB 1600 printed Mar 13, 2025@21:24:06 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
