PRCNUTL1 ;SSI/ALA-Utility Program ;[ 04/24/96 2:12 PM ]
;;1.0;Equipment/Turn-In Request;**5,17**;Sep 13, 1996;Build 4
LOC ; Translate location field into pointer and store it
;
;PRCN*1.0*17 Modified vendor lookup/set to insure the DIE
; value remained at '^PRCN(413,'. Also, for
; null Training Vendor set additional Training
; Vendor Name to null, besides Vendor Training
; pointer field in file 413 to null.
;
N DIEL,DM,DC,DH,DI,DK,DP,DL,DIFLD,DQ,DR,DIC,DA,X,Y
S X=$P($G(^PRCN(413,D0,2)),U,11),DIC(0)="EZ"
S DIC="^ENG(""SP""," D ^DIC I +Y<0 S $P(^PRCN(413,D0,2),U,19)="" Q
S DR="26////"_$P(Y,U,2)_";26.5////"_+Y,DA=D0 D ^DIE
Q
LOCHLP ; Executable help for Location field
S DUOUT=0,PRCNCT=0,HL0=0
F S HL0=$O(^DD(413,26,21,HL0)) Q:HL0'>0 W !,^DD(413,26,21,HL0,0)
W !!,"Locations currently in the space file:"
S L="" F S L=$O(^ENG("SP","B",L)) Q:L="" D T I $G(DUOUT)=1 S DUOUT=0 Q
K L,PRCNDI,PRCND,PRCNA,X
Q
VEN ; Translate training vendor field into pointer and store it
N DIEL,DM,DC,DH,DI,DK,DP,DL,DIFLD,DQ,DR,DIC,DA,X,Y
S X=$P($G(^PRCN(413,D0,7)),U,4),DIC(0)="EZ"
S DIC="^PRC(440," D ^DIC I +Y<0 S DA=D0,DR="55.5///@" D ^DIE Q ;PRCN*1.0*17
S DR="55////"_$P(Y,U,2)_";55.5////"_+Y,DA=D0 D ^DIE
Q
VENHLP ; Executable help for training vendor field
S DUOUT=0,PRCNCT=0,HL0=0
F S HL0=$O(^DD(413,55,21,HL0)) Q:HL0'>0 W !,^DD(413,55,21,HL0,0)
W !!,"Current Vendors: "
S L="" F S L=$O(^PRC(440,"B",L)) Q:L="" D T I $G(DUOUT)=1 S DUOUT=0 Q
K L,PRCNDI,PRCND,PRCNA,X
Q
EQHLP ; Special help for screening items from Equipment Inventory
S PRCND=$X,PRCNDI=21,PRCNCT=0
S:$G(PRCNCMR)="" PRCNCMR=$P(^PRCN(413.1,DA,0),U,16)
S N=0 F S N=$O(^ENG(6914,N)) Q:N'>0 D I $G(DUOUT)=1 S DUOUT=0 Q
. I $D(^PRCN(413.1,"AB",N)) Q
. S ACQ=$P($G(^ENG(6914,N,3)),U,4) I ACQ'="P"&(ACQ'="M")&(ACQ'="O")&(ACQ'="") Q
. I $P($G(^ENG(6914,N,2)),U,9)'=PRCNCMR Q
. S L=N_" "_$P(^ENG(6914,N,0),U,2) D T I $G(DUOUT)=1 Q
K PRCNDI,PRCND,PRCNA,N,ACQ
Q
T S PRCNCT=PRCNCT+1
I PRCNCT<10 W !,L Q
R !,"'^' TO STOP: ",PRCNA:DTIME S:'$T PRCNA=U
I $G(PRCNA)[U S DUOUT=1 Q
S PRCNCT=0
Q
UCK ; Check for user type and set screen
I $D(^XUSEC("PRCNPPM",DUZ)) Q
I $D(^XUSEC("PRCNCMR",DUZ)) S DIC("S")="I $P(^(0),U,6)=DUZ" Q
I $D(^XUSEC("PRCNWHSE",DUZ)) S DIC("S")="I $P(^(0),U,7)=22" Q
E S DIC("S")="I $P(^(0),U,2)=DUZ"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNUTL1 2433 printed Dec 13, 2024@01:54:48 Page 2
PRCNUTL1 ;SSI/ALA-Utility Program ;[ 04/24/96 2:12 PM ]
+1 ;;1.0;Equipment/Turn-In Request;**5,17**;Sep 13, 1996;Build 4
LOC ; Translate location field into pointer and store it
+1 ;
+2 ;PRCN*1.0*17 Modified vendor lookup/set to insure the DIE
+3 ; value remained at '^PRCN(413,'. Also, for
+4 ; null Training Vendor set additional Training
+5 ; Vendor Name to null, besides Vendor Training
+6 ; pointer field in file 413 to null.
+7 ;
+8 NEW DIEL,DM,DC,DH,DI,DK,DP,DL,DIFLD,DQ,DR,DIC,DA,X,Y
+9 SET X=$PIECE($GET(^PRCN(413,D0,2)),U,11)
SET DIC(0)="EZ"
+10 SET DIC="^ENG(""SP"","
DO ^DIC
IF +Y<0
SET $PIECE(^PRCN(413,D0,2),U,19)=""
QUIT
+11 SET DR="26////"_$PIECE(Y,U,2)_";26.5////"_+Y
SET DA=D0
DO ^DIE
+12 QUIT
LOCHLP ; Executable help for Location field
+1 SET DUOUT=0
SET PRCNCT=0
SET HL0=0
+2 FOR
SET HL0=$ORDER(^DD(413,26,21,HL0))
if HL0'>0
QUIT
WRITE !,^DD(413,26,21,HL0,0)
+3 WRITE !!,"Locations currently in the space file:"
+4 SET L=""
FOR
SET L=$ORDER(^ENG("SP","B",L))
if L=""
QUIT
DO T
IF $GET(DUOUT)=1
SET DUOUT=0
QUIT
+5 KILL L,PRCNDI,PRCND,PRCNA,X
+6 QUIT
VEN ; Translate training vendor field into pointer and store it
+1 NEW DIEL,DM,DC,DH,DI,DK,DP,DL,DIFLD,DQ,DR,DIC,DA,X,Y
+2 SET X=$PIECE($GET(^PRCN(413,D0,7)),U,4)
SET DIC(0)="EZ"
+3 ;PRCN*1.0*17
SET DIC="^PRC(440,"
DO ^DIC
IF +Y<0
SET DA=D0
SET DR="55.5///@"
DO ^DIE
QUIT
+4 SET DR="55////"_$PIECE(Y,U,2)_";55.5////"_+Y
SET DA=D0
DO ^DIE
+5 QUIT
VENHLP ; Executable help for training vendor field
+1 SET DUOUT=0
SET PRCNCT=0
SET HL0=0
+2 FOR
SET HL0=$ORDER(^DD(413,55,21,HL0))
if HL0'>0
QUIT
WRITE !,^DD(413,55,21,HL0,0)
+3 WRITE !!,"Current Vendors: "
+4 SET L=""
FOR
SET L=$ORDER(^PRC(440,"B",L))
if L=""
QUIT
DO T
IF $GET(DUOUT)=1
SET DUOUT=0
QUIT
+5 KILL L,PRCNDI,PRCND,PRCNA,X
+6 QUIT
EQHLP ; Special help for screening items from Equipment Inventory
+1 SET PRCND=$X
SET PRCNDI=21
SET PRCNCT=0
+2 if $GET(PRCNCMR)=""
SET PRCNCMR=$PIECE(^PRCN(413.1,DA,0),U,16)
+3 SET N=0
FOR
SET N=$ORDER(^ENG(6914,N))
if N'>0
QUIT
Begin DoDot:1
+4 IF $DATA(^PRCN(413.1,"AB",N))
QUIT
+5 SET ACQ=$PIECE($GET(^ENG(6914,N,3)),U,4)
IF ACQ'="P"&(ACQ'="M")&(ACQ'="O")&(ACQ'="")
QUIT
+6 IF $PIECE($GET(^ENG(6914,N,2)),U,9)'=PRCNCMR
QUIT
+7 SET L=N_" "_$PIECE(^ENG(6914,N,0),U,2)
DO T
IF $GET(DUOUT)=1
QUIT
End DoDot:1
IF $GET(DUOUT)=1
SET DUOUT=0
QUIT
+8 KILL PRCNDI,PRCND,PRCNA,N,ACQ
+9 QUIT
T SET PRCNCT=PRCNCT+1
+1 IF PRCNCT<10
WRITE !,L
QUIT
+2 READ !,"'^' TO STOP: ",PRCNA:DTIME
if '$TEST
SET PRCNA=U
+3 IF $GET(PRCNA)[U
SET DUOUT=1
QUIT
+4 SET PRCNCT=0
+5 QUIT
UCK ; Check for user type and set screen
+1 IF $DATA(^XUSEC("PRCNPPM",DUZ))
QUIT
+2 IF $DATA(^XUSEC("PRCNCMR",DUZ))
SET DIC("S")="I $P(^(0),U,6)=DUZ"
QUIT
+3 IF $DATA(^XUSEC("PRCNWHSE",DUZ))
SET DIC("S")="I $P(^(0),U,7)=22"
QUIT
+4 IF '$TEST
SET DIC("S")="I $P(^(0),U,2)=DUZ"
+5 QUIT
