- PRCHEI ;WISC/RWS-EDIT ROUTINES FOR ISMS CODE SHEETS ; 4/13/00 2:51pm
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN1 ;CREATE ACQUISITIONS LOG CODE SHEETS, UPDATE OBLIGATED BALANCE (IF SUPPLY FUND P.O.)
- D ST G:'$D(PRC("SITE")) Q D ASK^PRCHEC1 G:%=-1 Q I %=1 S PRCHQ="EN1" D EN^PRCHRCS
- EN01 Q:'$D(PRC("SITE")) G:$D(PRCHENT) Q2 S PRCHP("S")="$D(^PRC(442,""AE"",""N"",+Y))" D PO G:'$D(PRCHPO) Q
- I $D(^PRC(442,PRCHPO,1)),"013"[$P(^(1),U,7) S PRCHNRQ=1
- S %=1,%B="",%A=" Review Order " D ^PRCFYN G:%=-1 Q I %=1 S D0=PRCHPO D ^PRCHDP1
- ;
- EN11(PRCHTYP) ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
- D SETUP^PRCHEC1
- I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)]"" D ERR G EN01
- D LCK1 G:'$D(DA) EN01
- D EDIT^PRCHEC1 G:'$D(PRCHPO) EN01 S PRCHKEY=PRCHPONO W !!!
- D GT G:'% EN01
- D NEW^PRCHHI(PRCHPO,PRCHTYP,$G(PRCHRD))
- L @("-"_DIC_DA_")") G Q2
- ;
- Q K PRC,PRCHPO,PRCHN,PRCHNM,PRCHNRQ
- ;
- Q2 K PRCF,PRCFA,PRCFASYS,PRCHCS,PRCHTP,PRCHAMT,PRCHCNT,PRCHENT,PRCHRPT,PRCHRD,PRCHCMI,PRCHEMG,PRCHEST,PRCHFA,PRCHLOG,PRCHDIET,PRCHDPT,PRCHDRD,PRCHDT,PRCHDTP,PRCHKEY,PRCHPONO,PRCHT,PRCHTP,PRCHTYP,X,Y,Z
- K PRCHNET,PRCHAMT,PRCHSTA,PRCHBL,PRCHLOOP,PRCHTRID,PRCHTRLE,SPFILL,PRCHITFI,PRCHDEFI,BLANKS,LP,PRCHLINO,PRCHLIFI,PRCHLITM,PRCHDESC,PRCHDESP,PRCHDELE,PRCHAPPR,PRCHAPLE,FILL,PRCHOB22,OBCL,CL22
- Q
- ;
- LCK1 S DIC="^PRC(442,"
- ;
- LCK L @("+"_DIC_DA_"):0") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
- Q
- ;
- ST S PRCF("X")="S" D ^PRCFSITE
- Q
- ;
- PO S PRCHP("S")="""13478""[$P(^(0),U,2),"_PRCHP("S"),PRCHP("A")="P.O./REQ.NO.: " D EN3^PRCHPAT Q:'$D(PRCHPO) Q:'PRCHPO
- S PRCHSAVX=X S:'$D(^PRC(442,PRCHPO,18)) ^(18)="" I $P(^(18),U,3)="" D DOCID^PRCHUTL K Z
- S:'$D(^PRC(442,PRCHPO,17)) ^(17)="" I $P(^(17),U,1)="" D LOGDPT^PRCHEC2
- S X=PRCHSAVX K PRCHSAVX
- Q
- ;
- GT S PRCFASYS="ISM",PRCFA("SYS")="ISM",PRCFA("REF")=$P(PRCHPONO,"-",2),PRCFA("TTLEN")="" S:$G(PRCHTRAN)'="" PRCFA("TTF")=PRCHTRAN D TT^PRCFAC Q:'%
- K PRCHTP S PRCHTP(1)="442,"_PRCHPO_",^PRC(442,"
- Q
- ;
- ERR W !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$C(7)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHEI 2143 printed Jan 18, 2025@03:08:25 Page 2
- PRCHEI ;WISC/RWS-EDIT ROUTINES FOR ISMS CODE SHEETS ; 4/13/00 2:51pm
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- EN1 ;CREATE ACQUISITIONS LOG CODE SHEETS, UPDATE OBLIGATED BALANCE (IF SUPPLY FUND P.O.)
- +1 DO ST
- if '$DATA(PRC("SITE"))
- GOTO Q
- DO ASK^PRCHEC1
- if %=-1
- GOTO Q
- IF %=1
- SET PRCHQ="EN1"
- DO EN^PRCHRCS
- EN01 if '$DATA(PRC("SITE"))
- QUIT
- if $DATA(PRCHENT)
- GOTO Q2
- SET PRCHP("S")="$D(^PRC(442,""AE"",""N"",+Y))"
- DO PO
- if '$DATA(PRCHPO)
- GOTO Q
- +1 IF $DATA(^PRC(442,PRCHPO,1))
- IF "013"[$PIECE(^(1),U,7)
- SET PRCHNRQ=1
- +2 SET %=1
- SET %B=""
- SET %A=" Review Order "
- DO ^PRCFYN
- if %=-1
- GOTO Q
- IF %=1
- SET D0=PRCHPO
- DO ^PRCHDP1
- +3 ;
- EN11(PRCHTYP) ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
- +1 DO SETUP^PRCHEC1
- +2 IF $DATA(^PRC(442,PRCHPO,18))
- IF $PIECE(^(18),U,6)]""
- DO ERR
- GOTO EN01
- +3 DO LCK1
- if '$DATA(DA)
- GOTO EN01
- +4 DO EDIT^PRCHEC1
- if '$DATA(PRCHPO)
- GOTO EN01
- SET PRCHKEY=PRCHPONO
- WRITE !!!
- +5 DO GT
- if '%
- GOTO EN01
- +6 DO NEW^PRCHHI(PRCHPO,PRCHTYP,$GET(PRCHRD))
- +7 LOCK @("-"_DIC_DA_")")
- GOTO Q2
- +8 ;
- Q KILL PRC,PRCHPO,PRCHN,PRCHNM,PRCHNRQ
- +1 ;
- Q2 KILL PRCF,PRCFA,PRCFASYS,PRCHCS,PRCHTP,PRCHAMT,PRCHCNT,PRCHENT,PRCHRPT,PRCHRD,PRCHCMI,PRCHEMG,PRCHEST,PRCHFA,PRCHLOG,PRCHDIET,PRCHDPT,PRCHDRD,PRCHDT,PRCHDTP,PRCHKEY,PRCHPONO,PRCHT,PRCHTP,PRCHTYP,X,Y,Z
- +1 KILL PRCHNET,PRCHAMT,PRCHSTA,PRCHBL,PRCHLOOP,PRCHTRID,PRCHTRLE,SPFILL,PRCHITFI,PRCHDEFI,BLANKS,LP,PRCHLINO,PRCHLIFI,PRCHLITM,PRCHDESC,PRCHDESP,PRCHDELE,PRCHAPPR,PRCHAPLE,FILL,PRCHOB22,OBCL,CL22
- +2 QUIT
- +3 ;
- LCK1 SET DIC="^PRC(442,"
- +1 ;
- LCK LOCK @("+"_DIC_DA_"):0")
- IF '$TEST
- WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
- KILL DA
- +1 QUIT
- +2 ;
- ST SET PRCF("X")="S"
- DO ^PRCFSITE
- +1 QUIT
- +2 ;
- PO SET PRCHP("S")="""13478""[$P(^(0),U,2),"_PRCHP("S")
- SET PRCHP("A")="P.O./REQ.NO.: "
- DO EN3^PRCHPAT
- if '$DATA(PRCHPO)
- QUIT
- if 'PRCHPO
- QUIT
- +1 SET PRCHSAVX=X
- if '$DATA(^PRC(442,PRCHPO,18))
- SET ^(18)=""
- IF $PIECE(^(18),U,3)=""
- DO DOCID^PRCHUTL
- KILL Z
- +2 if '$DATA(^PRC(442,PRCHPO,17))
- SET ^(17)=""
- IF $PIECE(^(17),U,1)=""
- DO LOGDPT^PRCHEC2
- +3 SET X=PRCHSAVX
- KILL PRCHSAVX
- +4 QUIT
- +5 ;
- GT SET PRCFASYS="ISM"
- SET PRCFA("SYS")="ISM"
- SET PRCFA("REF")=$PIECE(PRCHPONO,"-",2)
- SET PRCFA("TTLEN")=""
- if $GET(PRCHTRAN)'=""
- SET PRCFA("TTF")=PRCHTRAN
- DO TT^PRCFAC
- if '%
- QUIT
- +1 KILL PRCHTP
- SET PRCHTP(1)="442,"_PRCHPO_",^PRC(442,"
- +2 QUIT
- +3 ;
- ERR WRITE !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$CHAR(7)
- +1 QUIT