- PRCHUTL ;SF/TKW/ID/RSD-UTILITY ROUTINES FOR SUPPLY SYSTEM ; 5/10/99 10:58am
- ;;5.1;IFCAP;**15**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN2 ;CALLED FROM FILE 441 FIELD .01, INPUT X="NEW", OUTPUT X=NEXT INTERNAL NUMBER
- S PRCHU=$P(^PRC(441,0),U,3) F I=1:1 S PRCHU=PRCHU+1 I '$D(^PRC(441,PRCHU)) L ^PRC(441,PRCHU) I S (X,DIX)=PRCHU K PRCHU Q
- Q
- ;
- ENPO ;ENTER NEW PO IN FILE 442
- K PRCHPO,PRCHNEW,DA,DIC,DLAYGO,L Q:'$D(PRC("SITE"))
- I '$D(DT) S X="T" D ^%DT S DT=Y
- W !!,"ENTER A NEW "_$S($G(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER NUMBER OR A COMMON NUMBERING SERIES"
- W !?3,$S($G(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER: " R X:DTIME
- G:X=""!(X=U) ENPOQ
- D:'$D(DIC("S"))
- . S DIC="^PRC(442.6,",DIC(0)="QEMZ"
- . I $G(PRCHPC) S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=6"
- . E I $G(PRCHDELV) S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=7"
- . E S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6))"
- I $L(X)<4!($E(X,1)="?") S D="C" D IX^DIC G ENPO:Y<0,NUM:$L(X)<4
- I '$O(^PRC(442.6,"B",PRC("SITE")_"-"_$E(X,1,2),0)) W " ??? Not part of an existing Common Numbering Series." G ENPO
- I $E(X,1,2)["B" W $C(7),!! W "'B' numbers are normally used for Acquisitions from Federal Sources." S %A=" ARE YOU SURE ",%B="This number should only be used for Federal Source Acquisitions",%=2 D ^PRCFYN G:%=-1 ENPOQ G:%'=1 ENPO
- S X=PRC("SITE")_"-"_X I $D(^PRC(442,"B",X)) W !?3,"P.O. ",X," already exist, use edit option to modify." G ENPO
- ;
- ENPO1 K DIC("S") S PRCHNEW="",DIC="^PRC(442,",DLAYGO=442,DIC(0)="L" D ^DIC L G ENPO:Y<0,W3:'+$P(Y,U,3)
- S (DA,PRCHPO)=+Y,%DT="T",X="NOW" D ^%DT S $P(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
- S (X,Y)=1,DA=PRCHPO D UPD^PRCHSTAT
- S $P(^PRC(442,PRCHPO,1),U,10)=DUZ
- D DOCID
- G ENPOQ
- ;
- NUM L ^PRC(442.6,+Y,0):1 G:'$T W1 S X=$P(Y,U,2),Z=$S(+$P(Y(0),U,4)<$P(Y(0),U,2):+$P(Y(0),U,2),1:+$P(Y(0),U,4)),L=$L(X)#2-3
- ;
- Z G:Z>$P(Y(0),U,3) W2 S Z="000"_Z,Z=$E(Z,$L(Z)+L,$L(Z)),X=X_Z I $D(^PRC(442,"B",X)) S Z=Z+1,X=$P(Y,U,2) G Z
- W $C(7) S %A=" Are you adding '"_X_"' as a new Purchase Order number ",%B="",%="" D ^PRCFYN I %'=1 L G ENPO
- S $P(^PRC(442.6,+Y,0),U,4)=+Z
- G ENPO1
- ;
- DOCID S Z=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2) Q:$L(Z)'=6 F I=1:1:6 S X=$E(Z,I,I) Q:+X=X
- I +X=X S $P(^PRC(442,PRCHPO,18),"^",3)=$S(I=1:$E(Z,2,6),1:$E(Z,1,I-1)_$E(Z,I+1,6))
- Q
- ;
- W1 L W !?3," Common numbering series is being edited by another user, try later",$C(7)
- G ENPO
- ;
- W2 L W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(Y,U,2),$C(7)
- G ENPO
- ;
- W3 W " Purchase Order number already exist, please try again ",$C(7)
- G ENPO
- ;
- ENPOQ K DIC,DLAYGO,%DT,PRCHNEW,L
- Q
- ;several old linetags that encoded/decoded esigs were removed from here
- ;
- WORD ; PRCH=GLOBAL,WX=LINE TO INSERT
- I '$D(@(PRCH_"0)")) S @(PRCH_"0)")="^^0^0^"_DT
- S WI=0 F WJ=1:1 S WI=$O(@(PRCH_WI_")")) Q:'WI I $D(^(WI,0)) S WY=^(0),^(0)=WX,WX=WY
- S $P(@(PRCH_"0)"),U,3,4)=WJ_U_WJ,^(WJ,0)=WX K WI,WJ,WX,WY
- Q
- ;
- SWITCH N X K PRCHLOG,PRCHISMS S X=$$ISMSFLAG^PRCPUX2(PRC("SITE")) S:X#2 PRCHLOG="" S:X\2 PRCHISMS="",PRCHTYP="I"
- Q
- ;
- EDISTAT(D0,D1,LINECNT) ;DISPLAY P.O.'S EDI STATUS & QUANTITY
- ;REQUIRES INTERNAL RECORD NUMBER AS D0
- ; INTERNAL SUBRECORD NUMBER AS D1
- ; RETURNS THE NUMBER OF LINES PRINTED AS LINECNT
- ;NOTE: THE NAKED REFERENCE WILL BE ^DD(442.01,12 or 13,0) WHEN
- ; THIS MODULE FINISHES.
- N X,Y,C
- S:'$D(LINECNT) LINECNT=0
- I $D(^PRC(442,D0,2,D1,2)) S X=$P(^(2),"^",9,12) D
- .I $P(X,"^",1)=""&($P(X,"^",3)="") Q
- .W !," E D I S T A T U S : ",?26
- .I $P(X,"^",1)]"" S Y=$P(X,"^",1),C=$P(^DD(442.01,12,0),"^",2) D Y^DIQ W "#1: ",Y," QTY: ",$P(X,"^",2),!,?26 S LINECNT=LINECNT+1
- .I $P(X,"^",3)]"" S Y=$P(X,"^",3),C=$P(^DD(442.01,13,0),"^",2) D Y^DIQ W "#2: ",Y," QTY: ",$P(X,"^",4) S LINECNT=LINECNT+1
- .W ! S LINECNT=LINECNT+1
- .Q
- Q
- ;
- ;
- ;
- VEN(A) ; Entry point to get FMS Vendor ID_ Alt.Address Indicator from the vendor file. -- Used by AR (Only)
- ; A = internal entry number to vendor file (#440)
- ;
- N T S T=$G(^PRC(440,+A,3))
- I $L($P(T,U,4))'=9 Q ""
- Q $P(T,U,4)_$P(T,U,5)
- ;
- VENSEL() ; VENSEL = VENdor SELection
- ; EXTRINSIC FUNCTION THAT ALLOWS A USER TO SELECT AN IFCAP VENDOR.
- ; THIS FUNCTION WILL BE USED BY ACCOUNTS RECEIVABLE USERS.
- ;
- ; THIS EXTRINSIC FUNCTION WILL RETURN A STRING.
- ; CONDITION STRING VALUE ^DIC VALUE
- ; LOOKUP FAILED -1 Y=-1
- ; TIMED-OUT -2 DTOUT
- ; UP-ARROW -3 DUOUT
- ; SUCCESSFUL DA^.01 FIELD Y=N^S
- ; SUCCESSFUL & NEW DA^.01 FIELD^1 Y=N^S^1
- ;
- ; THE DEFINITIONS OF THE ^DIC VALUEs MAY BE FOUND IN VA FileMan
- ; V.21.0 Programmer Manual ON PAGES 56-57. THIS IS THE RETURNED
- ; STRING OF THIS FUNCTION.
- ;
- ; FIRST, ASK THE USER FOR THEIR "SITE".
- ;
- S PRCF("X")="S"
- D ^PRCFSITE
- ;
- ; NOW THAT WE HAVE THE SITE, CONTINUE ON.
- ;
- S DIC="^PRC(440,"
- S DIC(0)="AEMO"
- S DIC("A")="Select the DEBTOR from the VENDOR list: "
- K DTOUT,DUOUT
- D ^DIC
- S:$D(DTOUT) Y=-2
- S:$D(DUOUT) Y=-3
- K DIC,DTOUT,DUOUT
- S PRCOY=Y
- I +PRCOY<0 Q PRCOY
- ;
- ; NOW LETS SEE IF THIS VENDOR RECORD IS PROPERLY SET UP.
- ;
- S DA=+Y
- K ^PRC(440.3,DA)
- S %X="^PRC(440,DA,"
- S %Y="^PRC(440.3,DA,"
- D %XY^%RCR
- S FLAG=1
- S FISCAL=$G(^PRC(411,PRC("SITE"),9))
- S FISCAL=$P(FISCAL,U,3)
- S SAVE=$$CHECK^PRCOVTST(DA,PRC("SITE"),FLAG)
- I FISCAL="Y",SAVE=0 D
- . S DIE="^PRC(440.3,"
- . S DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
- . D ^DIE
- . Q
- I FISCAL'="Y",SAVE=0 S PRCZDA=DA D VRQ^PRCOVTST(DA,PRC("SITE")) S DA=PRCZDA K PRCZDA
- I SAVE=1 D
- . S AR=449
- . S DIE="^PRC(440.3,"
- . S DR="50///^S X=FLAG;51///^S X=DA;52///^S X=PRC(""SITE"")"
- . D ^DIE
- . K AR
- . Q
- Q PRCOY
- ;
- AF ; CALLED BY "AF" X-REF IN FIELD 52 (SITE AR) IN FILE 440.3.
- N PRCX,DIC,DLAYGO,Y
- Q:$G(AR)'=449
- S PRCX=$O(^PRCF(422.2,"B","AR-EDIT-01",0)) D:PRCX=""
- . ; NEED TO SET UP ENTRY IN COUNTER FILE.
- . K DD,DO
- . S DIC="^PRCF(422.2,"
- . S DIC(0)="L"
- . S X="AR-EDIT-01"
- . S DELAYGO=422.2
- . D FILE^DICN
- . S PRCX=+Y
- . Q
- S $P(^PRCF(422.2,PRCX,0),U,2)=+$P(^PRCF(422.2,PRCX,0),U,2)+1
- Q
- ;
- VENEDITF ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
- ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
- ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
- ;
- ; SEE IF FISCAL CAN ADD A VENDOR. IF SO, TELL THE USER THERE
- ; RECORDS TO EDIT.
- ;
- N COUNT,STN411,SHOWIT
- Q:'$D(DUZ) ; YOU ARE UNDEFINED.
- ;
- ; SEE IF FISCAL CAN ADD VENDORS.
- ;
- D FIND
- Q:STN411'=1
- ;
- S SHOWIT=0
- ;
- ; I STN411=1 THEN FISCAL CAN ADD VENDORS.
- ; SEE IF THE USER IS A FISCAL USER.
- ;
- I $D(^XUSEC("PRCFA VENDOR EDIT",DUZ))=1 S SHOWIT=1
- Q:SHOWIT'=1
- G COUNT
- ;
- VENEDITS ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
- ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
- ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
- ;
- ; SEE IF FISCAL CAN ADD A VENDOR. IF NOT, HAVE SUPPLY EDIT THE
- ; VENDOR RECORDS.
- ;
- N COUNT,STN411,SHOWIT
- Q:'$D(DUZ) ; YOU ARE UNDEFINED.
- ;
- ; SEE IF FISCAL CAN ADD VENDORS.
- ;
- D FIND
- Q:STN411=1
- ;
- S SHOWIT=0
- ;
- ; SEE IF THE USER IS A PURCHASING AGENT OR A MANAGER.
- ;
- I +$P($G(^VA(200,DUZ,400)),U)>2 S SHOWIT=1
- Q:SHOWIT'=1
- ;
- COUNT ; NOW SHOW MESSAGE, IF ANY
- ;
- S COUNT=$O(^PRCF(422.2,"B","AR-EDIT-01",0)) Q:COUNT'>0
- S COUNT=$P($G(^PRCF(422.2,COUNT,0)),U,2) Q:COUNT'>0
- W !!,"There are Vendor Records that AR is using to be edited."
- Q
- ;
- FIND ; SEE IF FISCAL CAN ADD A VENDOR.
- ;
- N STATION,STNIEN
- S STATION=0
- S STN411=""
- F S STATION=$O(^PRC(411,"B",STATION)) Q:STATION']"" D Q:STN411=1
- . S STNIEN=$O(^PRC(411,"B",STATION,0)) Q:STNIEN'>0
- . S STN411=$P($G(^PRC(411,STNIEN,0)),U,20)
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHUTL 8001 printed Jan 18, 2025@03:12:37 Page 2
- PRCHUTL ;SF/TKW/ID/RSD-UTILITY ROUTINES FOR SUPPLY SYSTEM ; 5/10/99 10:58am
- +1 ;;5.1;IFCAP;**15**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN2 ;CALLED FROM FILE 441 FIELD .01, INPUT X="NEW", OUTPUT X=NEXT INTERNAL NUMBER
- +1 SET PRCHU=$PIECE(^PRC(441,0),U,3)
- FOR I=1:1
- SET PRCHU=PRCHU+1
- IF '$DATA(^PRC(441,PRCHU))
- LOCK ^PRC(441,PRCHU)
- IF $TEST
- SET (X,DIX)=PRCHU
- KILL PRCHU
- QUIT
- +2 QUIT
- +3 ;
- ENPO ;ENTER NEW PO IN FILE 442
- +1 KILL PRCHPO,PRCHNEW,DA,DIC,DLAYGO,L
- if '$DATA(PRC("SITE"))
- QUIT
- +2 IF '$DATA(DT)
- SET X="T"
- DO ^%DT
- SET DT=Y
- +3 WRITE !!,"ENTER A NEW "_$SELECT($GET(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER NUMBER OR A COMMON NUMBERING SERIES"
- +4 WRITE !?3,$SELECT($GET(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER: "
- READ X:DTIME
- +5 if X=""!(X=U)
- GOTO ENPOQ
- +6 if '$DATA(DIC("S"))
- Begin DoDot:1
- +7 SET DIC="^PRC(442.6,"
- SET DIC(0)="QEMZ"
- +8 IF $GET(PRCHPC)
- SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=6"
- +9 IF '$TEST
- IF $GET(PRCHDELV)
- SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=7"
- +10 IF '$TEST
- SET DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6))"
- End DoDot:1
- +11 IF $LENGTH(X)<4!($EXTRACT(X,1)="?")
- SET D="C"
- DO IX^DIC
- if Y<0
- GOTO ENPO
- if $LENGTH(X)<4
- GOTO NUM
- +12 IF '$ORDER(^PRC(442.6,"B",PRC("SITE")_"-"_$EXTRACT(X,1,2),0))
- WRITE " ??? Not part of an existing Common Numbering Series."
- GOTO ENPO
- +13 IF $EXTRACT(X,1,2)["B"
- WRITE $CHAR(7),!!
- WRITE "'B' numbers are normally used for Acquisitions from Federal Sources."
- SET %A=" ARE YOU SURE "
- SET %B="This number should only be used for Federal Source Acquisitions"
- SET %=2
- DO ^PRCFYN
- if %=-1
- GOTO ENPOQ
- if %'=1
- GOTO ENPO
- +14 SET X=PRC("SITE")_"-"_X
- IF $DATA(^PRC(442,"B",X))
- WRITE !?3,"P.O. ",X," already exist, use edit option to modify."
- GOTO ENPO
- +15 ;
- ENPO1 KILL DIC("S")
- SET PRCHNEW=""
- SET DIC="^PRC(442,"
- SET DLAYGO=442
- SET DIC(0)="L"
- DO ^DIC
- LOCK
- if Y<0
- GOTO ENPO
- if '+$PIECE(Y,U,3)
- GOTO W3
- +1 SET (DA,PRCHPO)=+Y
- SET %DT="T"
- SET X="NOW"
- DO ^%DT
- SET $PIECE(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
- +2 SET (X,Y)=1
- SET DA=PRCHPO
- DO UPD^PRCHSTAT
- +3 SET $PIECE(^PRC(442,PRCHPO,1),U,10)=DUZ
- +4 DO DOCID
- +5 GOTO ENPOQ
- +6 ;
- NUM LOCK ^PRC(442.6,+Y,0):1
- if '$TEST
- GOTO W1
- SET X=$PIECE(Y,U,2)
- SET Z=$SELECT(+$PIECE(Y(0),U,4)<$PIECE(Y(0),U,2):+$PIECE(Y(0),U,2),1:+$PIECE(Y(0),U,4))
- SET L=$LENGTH(X)#2-3
- +1 ;
- Z if Z>$PIECE(Y(0),U,3)
- GOTO W2
- SET Z="000"_Z
- SET Z=$EXTRACT(Z,$LENGTH(Z)+L,$LENGTH(Z))
- SET X=X_Z
- IF $DATA(^PRC(442,"B",X))
- SET Z=Z+1
- SET X=$PIECE(Y,U,2)
- GOTO Z
- +1 WRITE $CHAR(7)
- SET %A=" Are you adding '"_X_"' as a new Purchase Order number "
- SET %B=""
- SET %=""
- DO ^PRCFYN
- IF %'=1
- LOCK
- GOTO ENPO
- +2 SET $PIECE(^PRC(442.6,+Y,0),U,4)=+Z
- +3 GOTO ENPO1
- +4 ;
- DOCID SET Z=$PIECE($PIECE(^PRC(442,PRCHPO,0),U,1),"-",2)
- if $LENGTH(Z)'=6
- QUIT
- FOR I=1:1:6
- SET X=$EXTRACT(Z,I,I)
- if +X=X
- QUIT
- +1 IF +X=X
- SET $PIECE(^PRC(442,PRCHPO,18),"^",3)=$SELECT(I=1:$EXTRACT(Z,2,6),1:$EXTRACT(Z,1,I-1)_$EXTRACT(Z,I+1,6))
- +2 QUIT
- +3 ;
- W1 LOCK
- WRITE !?3," Common numbering series is being edited by another user, try later",$CHAR(7)
- +1 GOTO ENPO
- +2 ;
- W2 LOCK
- WRITE !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$PIECE(Y,U,2),$CHAR(7)
- +1 GOTO ENPO
- +2 ;
- W3 WRITE " Purchase Order number already exist, please try again ",$CHAR(7)
- +1 GOTO ENPO
- +2 ;
- ENPOQ KILL DIC,DLAYGO,%DT,PRCHNEW,L
- +1 QUIT
- +2 ;several old linetags that encoded/decoded esigs were removed from here
- +3 ;
- WORD ; PRCH=GLOBAL,WX=LINE TO INSERT
- +1 IF '$DATA(@(PRCH_"0)"))
- SET @(PRCH_"0)")="^^0^0^"_DT
- +2 SET WI=0
- FOR WJ=1:1
- SET WI=$ORDER(@(PRCH_WI_")"))
- if 'WI
- QUIT
- IF $DATA(^(WI,0))
- SET WY=^(0)
- SET ^(0)=WX
- SET WX=WY
- +3 SET $PIECE(@(PRCH_"0)"),U,3,4)=WJ_U_WJ
- SET ^(WJ,0)=WX
- KILL WI,WJ,WX,WY
- +4 QUIT
- +5 ;
- SWITCH NEW X
- KILL PRCHLOG,PRCHISMS
- SET X=$$ISMSFLAG^PRCPUX2(PRC("SITE"))
- if X#2
- SET PRCHLOG=""
- if X\2
- SET PRCHISMS=""
- SET PRCHTYP="I"
- +1 QUIT
- +2 ;
- EDISTAT(D0,D1,LINECNT) ;DISPLAY P.O.'S EDI STATUS & QUANTITY
- +1 ;REQUIRES INTERNAL RECORD NUMBER AS D0
- +2 ; INTERNAL SUBRECORD NUMBER AS D1
- +3 ; RETURNS THE NUMBER OF LINES PRINTED AS LINECNT
- +4 ;NOTE: THE NAKED REFERENCE WILL BE ^DD(442.01,12 or 13,0) WHEN
- +5 ; THIS MODULE FINISHES.
- +6 NEW X,Y,C
- +7 if '$DATA(LINECNT)
- SET LINECNT=0
- +8 IF $DATA(^PRC(442,D0,2,D1,2))
- SET X=$PIECE(^(2),"^",9,12)
- Begin DoDot:1
- +9 IF $PIECE(X,"^",1)=""&($PIECE(X,"^",3)="")
- QUIT
- +10 WRITE !," E D I S T A T U S : ",?26
- +11 IF $PIECE(X,"^",1)]""
- SET Y=$PIECE(X,"^",1)
- SET C=$PIECE(^DD(442.01,12,0),"^",2)
- DO Y^DIQ
- WRITE "#1: ",Y," QTY: ",$PIECE(X,"^",2),!,?26
- SET LINECNT=LINECNT+1
- +12 IF $PIECE(X,"^",3)]""
- SET Y=$PIECE(X,"^",3)
- SET C=$PIECE(^DD(442.01,13,0),"^",2)
- DO Y^DIQ
- WRITE "#2: ",Y," QTY: ",$PIECE(X,"^",4)
- SET LINECNT=LINECNT+1
- +13 WRITE !
- SET LINECNT=LINECNT+1
- +14 QUIT
- End DoDot:1
- +15 QUIT
- +16 ;
- +17 ;
- +18 ;
- VEN(A) ; Entry point to get FMS Vendor ID_ Alt.Address Indicator from the vendor file. -- Used by AR (Only)
- +1 ; A = internal entry number to vendor file (#440)
- +2 ;
- +3 NEW T
- SET T=$GET(^PRC(440,+A,3))
- +4 IF $LENGTH($PIECE(T,U,4))'=9
- QUIT ""
- +5 QUIT $PIECE(T,U,4)_$PIECE(T,U,5)
- +6 ;
- VENSEL() ; VENSEL = VENdor SELection
- +1 ; EXTRINSIC FUNCTION THAT ALLOWS A USER TO SELECT AN IFCAP VENDOR.
- +2 ; THIS FUNCTION WILL BE USED BY ACCOUNTS RECEIVABLE USERS.
- +3 ;
- +4 ; THIS EXTRINSIC FUNCTION WILL RETURN A STRING.
- +5 ; CONDITION STRING VALUE ^DIC VALUE
- +6 ; LOOKUP FAILED -1 Y=-1
- +7 ; TIMED-OUT -2 DTOUT
- +8 ; UP-ARROW -3 DUOUT
- +9 ; SUCCESSFUL DA^.01 FIELD Y=N^S
- +10 ; SUCCESSFUL & NEW DA^.01 FIELD^1 Y=N^S^1
- +11 ;
- +12 ; THE DEFINITIONS OF THE ^DIC VALUEs MAY BE FOUND IN VA FileMan
- +13 ; V.21.0 Programmer Manual ON PAGES 56-57. THIS IS THE RETURNED
- +14 ; STRING OF THIS FUNCTION.
- +15 ;
- +16 ; FIRST, ASK THE USER FOR THEIR "SITE".
- +17 ;
- +18 SET PRCF("X")="S"
- +19 DO ^PRCFSITE
- +20 ;
- +21 ; NOW THAT WE HAVE THE SITE, CONTINUE ON.
- +22 ;
- +23 SET DIC="^PRC(440,"
- +24 SET DIC(0)="AEMO"
- +25 SET DIC("A")="Select the DEBTOR from the VENDOR list: "
- +26 KILL DTOUT,DUOUT
- +27 DO ^DIC
- +28 if $DATA(DTOUT)
- SET Y=-2
- +29 if $DATA(DUOUT)
- SET Y=-3
- +30 KILL DIC,DTOUT,DUOUT
- +31 SET PRCOY=Y
- +32 IF +PRCOY<0
- QUIT PRCOY
- +33 ;
- +34 ; NOW LETS SEE IF THIS VENDOR RECORD IS PROPERLY SET UP.
- +35 ;
- +36 SET DA=+Y
- +37 KILL ^PRC(440.3,DA)
- +38 SET %X="^PRC(440,DA,"
- +39 SET %Y="^PRC(440.3,DA,"
- +40 DO %XY^%RCR
- +41 SET FLAG=1
- +42 SET FISCAL=$GET(^PRC(411,PRC("SITE"),9))
- +43 SET FISCAL=$PIECE(FISCAL,U,3)
- +44 SET SAVE=$$CHECK^PRCOVTST(DA,PRC("SITE"),FLAG)
- +45 IF FISCAL="Y"
- IF SAVE=0
- Begin DoDot:1
- +46 SET DIE="^PRC(440.3,"
- +47 SET DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
- +48 DO ^DIE
- +49 QUIT
- End DoDot:1
- +50 IF FISCAL'="Y"
- IF SAVE=0
- SET PRCZDA=DA
- DO VRQ^PRCOVTST(DA,PRC("SITE"))
- SET DA=PRCZDA
- KILL PRCZDA
- +51 IF SAVE=1
- Begin DoDot:1
- +52 SET AR=449
- +53 SET DIE="^PRC(440.3,"
- +54 SET DR="50///^S X=FLAG;51///^S X=DA;52///^S X=PRC(""SITE"")"
- +55 DO ^DIE
- +56 KILL AR
- +57 QUIT
- End DoDot:1
- +58 QUIT PRCOY
- +59 ;
- AF ; CALLED BY "AF" X-REF IN FIELD 52 (SITE AR) IN FILE 440.3.
- +1 NEW PRCX,DIC,DLAYGO,Y
- +2 if $GET(AR)'=449
- QUIT
- +3 SET PRCX=$ORDER(^PRCF(422.2,"B","AR-EDIT-01",0))
- if PRCX=""
- Begin DoDot:1
- +4 ; NEED TO SET UP ENTRY IN COUNTER FILE.
- +5 KILL DD,DO
- +6 SET DIC="^PRCF(422.2,"
- +7 SET DIC(0)="L"
- +8 SET X="AR-EDIT-01"
- +9 SET DELAYGO=422.2
- +10 DO FILE^DICN
- +11 SET PRCX=+Y
- +12 QUIT
- End DoDot:1
- +13 SET $PIECE(^PRCF(422.2,PRCX,0),U,2)=+$PIECE(^PRCF(422.2,PRCX,0),U,2)+1
- +14 QUIT
- +15 ;
- VENEDITF ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
- +1 ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
- +2 ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
- +3 ;
- +4 ; SEE IF FISCAL CAN ADD A VENDOR. IF SO, TELL THE USER THERE
- +5 ; RECORDS TO EDIT.
- +6 ;
- +7 NEW COUNT,STN411,SHOWIT
- +8 ; YOU ARE UNDEFINED.
- if '$DATA(DUZ)
- QUIT
- +9 ;
- +10 ; SEE IF FISCAL CAN ADD VENDORS.
- +11 ;
- +12 DO FIND
- +13 if STN411'=1
- QUIT
- +14 ;
- +15 SET SHOWIT=0
- +16 ;
- +17 ; I STN411=1 THEN FISCAL CAN ADD VENDORS.
- +18 ; SEE IF THE USER IS A FISCAL USER.
- +19 ;
- +20 IF $DATA(^XUSEC("PRCFA VENDOR EDIT",DUZ))=1
- SET SHOWIT=1
- +21 if SHOWIT'=1
- QUIT
- +22 GOTO COUNT
- +23 ;
- VENEDITS ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
- +1 ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
- +2 ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
- +3 ;
- +4 ; SEE IF FISCAL CAN ADD A VENDOR. IF NOT, HAVE SUPPLY EDIT THE
- +5 ; VENDOR RECORDS.
- +6 ;
- +7 NEW COUNT,STN411,SHOWIT
- +8 ; YOU ARE UNDEFINED.
- if '$DATA(DUZ)
- QUIT
- +9 ;
- +10 ; SEE IF FISCAL CAN ADD VENDORS.
- +11 ;
- +12 DO FIND
- +13 if STN411=1
- QUIT
- +14 ;
- +15 SET SHOWIT=0
- +16 ;
- +17 ; SEE IF THE USER IS A PURCHASING AGENT OR A MANAGER.
- +18 ;
- +19 IF +$PIECE($GET(^VA(200,DUZ,400)),U)>2
- SET SHOWIT=1
- +20 if SHOWIT'=1
- QUIT
- +21 ;
- COUNT ; NOW SHOW MESSAGE, IF ANY
- +1 ;
- +2 SET COUNT=$ORDER(^PRCF(422.2,"B","AR-EDIT-01",0))
- if COUNT'>0
- QUIT
- +3 SET COUNT=$PIECE($GET(^PRCF(422.2,COUNT,0)),U,2)
- if COUNT'>0
- QUIT
- +4 WRITE !!,"There are Vendor Records that AR is using to be edited."
- +5 QUIT
- +6 ;
- FIND ; SEE IF FISCAL CAN ADD A VENDOR.
- +1 ;
- +2 NEW STATION,STNIEN
- +3 SET STATION=0
- +4 SET STN411=""
- +5 FOR
- SET STATION=$ORDER(^PRC(411,"B",STATION))
- if STATION']""
- QUIT
- Begin DoDot:1
- +6 SET STNIEN=$ORDER(^PRC(411,"B",STATION,0))
- if STNIEN'>0
- QUIT
- +7 SET STN411=$PIECE($GET(^PRC(411,STNIEN,0)),U,20)
- +8 QUIT
- End DoDot:1
- if STN411=1
- QUIT
- +9 QUIT