- 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 Feb 18, 2025@23:21:11 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