- PRCHDEP3 ;WISC/RWS-DEPOT EDIT FOR SUPPLY SYSTEM--LOG CODE SHEETS ;3/9/92 11:35 AM
- 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^PRCHDEP4 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 ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
- D SETUP^PRCHDEP4,CAL2^PRCHEC2
- ;IF SUPPLY FUND P.O. & NOT IMPREST FUNDS, UPDATE OBLIGATED BALANCE. IF PAYMENT IN ADVANCE, SET STATUS TO 'TRANSACTION COMPLETE'
- I PRCHN("SFC")=2,PRCHN("MP")'=12,'$D(PRCHNRQ) D OBL^PRCHDEP4 G:'$D(PRCHPO) Q I $P(^PRC(442,PRCHPO,0),U,2)=3 S X=40,DA=PRCHPO D ENS^PRCHSTAT
- I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)]"" D ERR G EN01
- D LCK1 G:'$D(DA) EN01
- S PRCHTYP="A" D EDIT^PRCHDEP4 G:'$D(PRCHPO) EN01 S PRCHKEY=PRCHPONO W !!!
- G EN001^PRCHDEP4
- ;
- EN2 ;CREATE LOG RECEIPT CODE SHEETS
- D ST G:'$D(PRC("SITE")) Q D ASK^PRCHDEP4 G:%=-1 Q I %=1 S PRCHQ="EN2",PRCHSAVQ=PRCHQ,PRCHQ=PRCHQ_"^PRCHRCS",PRCHQ("DEST")="S" D ^PRCHQUE
- EN20 Q:'$D(PRC("SITE")) S PRCHP("S")="$D(^PRC(442,""AF"",""N"",+Y))"
- D PO G:'$D(PRCHPO) Q I X<25!(X>44) W $C(7)," ??" G EN20
- D LCK1 G:'$D(DA) EN20
- I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"P.O. has no Receiving Reports !",$C(7) S DIC="^PRC(442," D UNLCK^PRCHDEP3 G EN20
- S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" D ^DIC K DIC G:Y<0 EN20 S (PRCHRPT,PRCHDPT)=+Y,(PRCHRD,PRCHDRD)=$P(Y(0),U,1),PRCHCMI=$S($P(Y(0),U,9)="":"P",1:"")
- I $D(^PRC(442,PRCHPO,11,PRCHRPT,1)),$P(^(1),U,4)]"" D ERR S DIC="^PRC(442," D UNLCK^PRCHDEP3 G EN20
- S PRCHTYP="R",PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1),PRCHKEY=PRCHPONO_"."_PRCHRPT
- ;S PRCHDIET=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:""),PRCHDTP=1
- S PRCHDIET=$P($G(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2),PRCHDTP=1
- W !!! S %A="DISPLAY RECEIVING REPORT ONLINE ",%=2 D ^PRCFYN G:%=-1 EN20 D:%=1 ^PRCHDP3 W !!!
- S PRCFA("DICS")="I Y=431!(Y=434)",PRCFA("TT")=$S($D(PRCHNRQ):431,1:434),PRCFA("EDIT")="[PRCHL"_PRCFA("TT")_"]"
- S Y=PRCFA("TT") D B431^PRCHDEP4
- D 1^PRCHDEP2
- G EN20
- ;
- 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
- Q
- ;
- ;CREATE REPORT OF CODE SHEETS TO BE GENERATED, FOR PPM
- LCK1 S DIC="^PRC(442,"
- LCK L @("+"_DIC_DA_"):5") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
- Q
- ;
- ST S PRCF("X")="S",PRCHLOG="",PRCFA("SYS")="LOG" D ^PRCFSITE Q:$P(PRC("PARAM"),U,7)=2
- W !,"This is not a DEPOT facility",!
- G 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 ;the ^(0),U,2 on line PO is a string set to a namespaced variable like DIC("S") which is used in EN3^PRCHPAT
- 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 PRCHLOG=1,PRCFASYS="LOG" D TT^PRCFAC Q:'% S PRCFA("TTF")=PRCFA("TT")
- K PRCHTP S PRCHTP(1)="442,"_PRCHPO_",^PRC(442,",PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
- Q
- ;
- ;K PRCHTP S:0 PRCHTP(1)="423,"_PRCFA("CSDA")_",^PRCF(423," Q
- ERR W !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$C(7)
- Q
- ;
- UNLCK ;RELEASE LOCK FOR "^PRC(442,DA"
- L @("-"_DIC_DA_")")
- Q
- ;
- UNLCK1 ;RELEASE LOCK FOR "^PRCF(423,DA"
- ;Screen out types "A" and "R" for this code to work. The variables
- ;PRCHCNT and PRCHLCNT are defined during DEPOT Due-in and Receiving
- ;Code Sheets Generation.
- ;
- I $D(PRCFA("CSDA")) S DA=PRCFA("CSDA")
- I PRCHTYP="A",PRCHCNT>0 F D Q:PRCHCNT=0
- . L -^PRCF(423,DA),-^PRCF(423,0)
- . S DA=$G(DA)-1,PRCHCNT=$G(PRCHCNT)-1
- ;
- I PRCHTYP="R",PRCHLCNT>0 F D Q:PRCHLCNT=0
- . L -^PRCF(423,DA),-^PRCF(423,0)
- . S DA=$G(DA)-1,PRCHLCNT=$G(PRCHLCNT)-1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDEP3 4258 printed Jan 18, 2025@03:07:48 Page 2
- PRCHDEP3 ;WISC/RWS-DEPOT EDIT FOR SUPPLY SYSTEM--LOG CODE SHEETS ;3/9/92 11:35 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;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.)
- +1 DO ST
- if '$DATA(PRC("SITE"))
- GOTO Q
- DO ASK^PRCHDEP4
- 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
- EN11 ;ENTRY POINT IF CALLED WHEN REQUISITION SIGNED.
- +1 DO SETUP^PRCHDEP4
- DO CAL2^PRCHEC2
- +2 ;IF SUPPLY FUND P.O. & NOT IMPREST FUNDS, UPDATE OBLIGATED BALANCE. IF PAYMENT IN ADVANCE, SET STATUS TO 'TRANSACTION COMPLETE'
- +3 IF PRCHN("SFC")=2
- IF PRCHN("MP")'=12
- IF '$DATA(PRCHNRQ)
- DO OBL^PRCHDEP4
- if '$DATA(PRCHPO)
- GOTO Q
- IF $PIECE(^PRC(442,PRCHPO,0),U,2)=3
- SET X=40
- SET DA=PRCHPO
- DO ENS^PRCHSTAT
- +4 IF $DATA(^PRC(442,PRCHPO,18))
- IF $PIECE(^(18),U,6)]""
- DO ERR
- GOTO EN01
- +5 DO LCK1
- if '$DATA(DA)
- GOTO EN01
- +6 SET PRCHTYP="A"
- DO EDIT^PRCHDEP4
- if '$DATA(PRCHPO)
- GOTO EN01
- SET PRCHKEY=PRCHPONO
- WRITE !!!
- +7 GOTO EN001^PRCHDEP4
- +8 ;
- EN2 ;CREATE LOG RECEIPT CODE SHEETS
- +1 DO ST
- if '$DATA(PRC("SITE"))
- GOTO Q
- DO ASK^PRCHDEP4
- if %=-1
- GOTO Q
- IF %=1
- SET PRCHQ="EN2"
- SET PRCHSAVQ=PRCHQ
- SET PRCHQ=PRCHQ_"^PRCHRCS"
- SET PRCHQ("DEST")="S"
- DO ^PRCHQUE
- EN20 if '$DATA(PRC("SITE"))
- QUIT
- SET PRCHP("S")="$D(^PRC(442,""AF"",""N"",+Y))"
- +1 DO PO
- if '$DATA(PRCHPO)
- GOTO Q
- IF X<25!(X>44)
- WRITE $CHAR(7)," ??"
- GOTO EN20
- +2 DO LCK1
- if '$DATA(DA)
- GOTO EN20
- +3 IF '$ORDER(^PRC(442,PRCHPO,11,0))
- WRITE !?3,"P.O. has no Receiving Reports !",$CHAR(7)
- SET DIC="^PRC(442,"
- DO UNLCK^PRCHDEP3
- GOTO EN20
- +4 SET DIC="^PRC(442,PRCHPO,11,"
- SET DIC(0)="QEANZ"
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO EN20
- SET (PRCHRPT,PRCHDPT)=+Y
- SET (PRCHRD,PRCHDRD)=$PIECE(Y(0),U,1)
- SET PRCHCMI=$SELECT($PIECE(Y(0),U,9)="":"P",1:"")
- +5 IF $DATA(^PRC(442,PRCHPO,11,PRCHRPT,1))
- IF $PIECE(^(1),U,4)]""
- DO ERR
- SET DIC="^PRC(442,"
- DO UNLCK^PRCHDEP3
- GOTO EN20
- +6 SET PRCHTYP="R"
- SET PRCHPONO=$PIECE(^PRC(442,PRCHPO,0),U,1)
- SET PRCHKEY=PRCHPONO_"."_PRCHRPT
- +7 ;S PRCHDIET=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:""),PRCHDTP=1
- +8 SET PRCHDIET=$PIECE($GET(^PRC(442,PRCHPO,11,PRCHRPT,1)),U,2)
- SET PRCHDTP=1
- +9 WRITE !!!
- SET %A="DISPLAY RECEIVING REPORT ONLINE "
- SET %=2
- DO ^PRCFYN
- if %=-1
- GOTO EN20
- if %=1
- DO ^PRCHDP3
- WRITE !!!
- +10 SET PRCFA("DICS")="I Y=431!(Y=434)"
- SET PRCFA("TT")=$SELECT($DATA(PRCHNRQ):431,1:434)
- SET PRCFA("EDIT")="[PRCHL"_PRCFA("TT")_"]"
- +11 SET Y=PRCFA("TT")
- DO B431^PRCHDEP4
- +12 DO 1^PRCHDEP2
- +13 GOTO EN20
- +14 ;
- Q KILL PRC,PRCHPO,PRCHN,PRCHNM,PRCHNRQ
- 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 QUIT
- +2 ;
- +3 ;CREATE REPORT OF CODE SHEETS TO BE GENERATED, FOR PPM
- LCK1 SET DIC="^PRC(442,"
- LCK LOCK @("+"_DIC_DA_"):5")
- IF '$TEST
- WRITE !,$CHAR(7),"ANOTHER USER IS EDITING THIS ENTRY!"
- KILL DA
- +1 QUIT
- +2 ;
- ST SET PRCF("X")="S"
- SET PRCHLOG=""
- SET PRCFA("SYS")="LOG"
- DO ^PRCFSITE
- if $PIECE(PRC("PARAM"),U,7)=2
- QUIT
- +1 WRITE !,"This is not a DEPOT facility",!
- +2 GOTO Q
- +3 ;
- PO ;the ^(0),U,2 on line PO is a string set to a namespaced variable like DIC("S") which is used in EN3^PRCHPAT
- 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 PRCHLOG=1
- SET PRCFASYS="LOG"
- DO TT^PRCFAC
- if '%
- QUIT
- SET PRCFA("TTF")=PRCFA("TT")
- +1 KILL PRCHTP
- SET PRCHTP(1)="442,"_PRCHPO_",^PRC(442,"
- SET PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
- +2 QUIT
- +3 ;
- +4 ;K PRCHTP S:0 PRCHTP(1)="423,"_PRCFA("CSDA")_",^PRCF(423," Q
- ERR WRITE !?3,"LOG code sheets already created and signed. Use Edit A Code Sheet option.",$CHAR(7)
- +1 QUIT
- +2 ;
- UNLCK ;RELEASE LOCK FOR "^PRC(442,DA"
- +1 LOCK @("-"_DIC_DA_")")
- +2 QUIT
- +3 ;
- UNLCK1 ;RELEASE LOCK FOR "^PRCF(423,DA"
- +1 ;Screen out types "A" and "R" for this code to work. The variables
- +2 ;PRCHCNT and PRCHLCNT are defined during DEPOT Due-in and Receiving
- +3 ;Code Sheets Generation.
- +4 ;
- +5 IF $DATA(PRCFA("CSDA"))
- SET DA=PRCFA("CSDA")
- +6 IF PRCHTYP="A"
- IF PRCHCNT>0
- FOR
- Begin DoDot:1
- +7 LOCK -^PRCF(423,DA),-^PRCF(423,0)
- +8 SET DA=$GET(DA)-1
- SET PRCHCNT=$GET(PRCHCNT)-1
- End DoDot:1
- if PRCHCNT=0
- QUIT
- +9 ;
- +10 IF PRCHTYP="R"
- IF PRCHLCNT>0
- FOR
- Begin DoDot:1
- +11 LOCK -^PRCF(423,DA),-^PRCF(423,0)
- +12 SET DA=$GET(DA)-1
- SET PRCHLCNT=$GET(PRCHLCNT)-1
- End DoDot:1
- if PRCHLCNT=0
- QUIT
- +13 QUIT