PRCPUMAN ;WISC/RFJ/DGL-lookup for mand source field .4 file 445 ; 7/22/99 1:49pm
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
HELP(INVPT,ITEMDA,SCREEN) ; called from help (node 4 for dd(445.01,.4, )
; to display mandatory source.
; screen=1 to lookup in screen for procurement source in 445.07
; optional prc("cp"),prc("site")
I 'INVPT!('ITEMDA) Q
N %,CP,MANSRCE,SITE,TYPE
S MANSRCE=$$MANDSRCE^PRCPU441(ITEMDA),TYPE=$P($G(^PRCP(445,INVPT,0)),"^",3)
S SITE=+$G(PRC("SITE")) I 'SITE S SITE=+$G(^PRCP(445,INVPT,0))
S CP=$G(PRC("CP")) I CP="" S CP=+$O(^PRC(420,"AE",SITE,INVPT,0)),CP=$P($G(^PRC(420,SITE,1,CP,0))," ") ; Multiple FCP not supported
W ! I TYPE="W" D W !! Q
. I MANSRCE'=$O(^PRC(440,"AC","S",0)) W !,"ITEM IS NOT SET UP AS POSTED STOCK. THE MANDATORY SOURCE IN THE ITEM MASTER",!,"FILE DOES NOT EQUAL THE WAREHOUSE VENDOR." Q
. S %=$P($G(^PRC(440,+$P($G(^PRC(441,ITEMDA,0)),"^",4),0)),"^") I %'="" W !,"LAST VENDOR ORDERED: ",%
. S %=$P($G(^PRC(440,+$P($G(^PRC(441,ITEMDA,4,SITE_CP,0)),"^",3),0)),"^") I %'="" W !,"PREFERRED VENDOR (FOR CP: ",CP,"): ",%
. W !,"YOU MAY SELECT ANY VENDOR WHICH IS SET UP AS A VENDOR FOR THIS ITEM IN THE ITEM",!,"MASTER FILE"
. W $S(SCREEN:", AND IS A PROCUREMENT SOURCE FOR THIS ITEM IN THE INVENTORY POINT.",1:". ") W:SCREEN ! W "THE VENDOR ALSO MUST NOT BE INACTIVATED."
I TYPE="P" D W !! Q
. I MANSRCE W !,"ITEM HAS A MANDATORY SOURCE: ",$P($G(^PRC(440,+MANSRCE,0)),"^"),".",!,"YOU CAN ONLY SELECT THIS VENDOR." Q
. S %=$P($G(^PRC(440,+$P($G(^PRC(441,ITEMDA,0)),"^",4),0)),"^") I %'="" W !,"LAST VENDOR ORDERED: ",%
. S %=$P($G(^PRC(440,+$P($G(^PRC(441,ITEMDA,4,SITE_CP,0)),"^",3),0)),"^") I %'="" W !,"PREFERRED VENDOR (FOR CP: ",CP,"): ",%
. W !,"YOU MAY SELECT ANY VENDOR WHICH IS SET UP AS A VENDOR FOR THIS ITEM IN THE ITEM",!,"MASTER FILE, AND IS A PROCUREMENT SOURCE FOR THIS ITEM IN THE INVENTORY POINT.",!,"THE VENDOR ALSO MUST NOT BE INACTIVATED."
I TYPE="S" D W !! Q
. W !,"YOU CAN ONLY SELECT A PRIMARY DISTRIBUTION POINT WHICH DISTRIBUTES THIS ITEM."
Q
;
;
SCREEN(INVPT,ITEMDA,SCREEN1) ; called from input transform for dd(445.01,.4,
; x=vendor name, y=vendor number,
; dic=file 440 or 445 it should lookup on
; screen1=1 to lookup in screen for procurement source in 445.07
; if vendor y fails -->> flag=0 and $t=0
N %,FLAG,LOOKUP,MANSRCE,SCREEN,TYPE
S FLAG=1
I 'INVPT!('ITEMDA) S FLAG=0 G END
S MANSRCE=$$MANDSRCE^PRCPU441(ITEMDA),TYPE=$P($G(^PRCP(445,INVPT,0)),"^",3),LOOKUP=$S($G(DIC)["^PRCP(445":";PRCP(445,",1:";PRC(440,")
S SCREEN="I LOOKUP[440,$D(^PRC(441,ITEMDA,2,+Y)),'$P($G(^PRC(440,+Y,10)),""^"",5)"_$S(SCREEN1:",$O(^PRCP(445,INVPT,1,ITEMDA,5,""B"",(+Y)_"";PRC(440,"",0))",1:"")
I TYPE="W" D G END
. I MANSRCE'=$O(^PRC(440,"AC","S",0)) S FLAG=0 Q
. I MANSRCE=Y S FLAG=0 Q
. X SCREEN I '$T S FLAG=0
I TYPE="P" D G END
. I MANSRCE,Y=MANSRCE Q
. I MANSRCE S FLAG=0 Q
. X SCREEN I '$T S FLAG=0
I TYPE="S" D
. I LOOKUP[445,$D(^PRCP(445,Y,1,ITEMDA,0)),$D(^PRCP(445,Y,2,INVPT,0)) Q
. S FLAG=0
END I FLAG Q
I 0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUMAN 3188 printed Dec 13, 2024@02:16:15 Page 2
PRCPUMAN ;WISC/RFJ/DGL-lookup for mand source field .4 file 445 ; 7/22/99 1:49pm
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
HELP(INVPT,ITEMDA,SCREEN) ; called from help (node 4 for dd(445.01,.4, )
+1 ; to display mandatory source.
+2 ; screen=1 to lookup in screen for procurement source in 445.07
+3 ; optional prc("cp"),prc("site")
+4 IF 'INVPT!('ITEMDA)
QUIT
+5 NEW %,CP,MANSRCE,SITE,TYPE
+6 SET MANSRCE=$$MANDSRCE^PRCPU441(ITEMDA)
SET TYPE=$PIECE($GET(^PRCP(445,INVPT,0)),"^",3)
+7 SET SITE=+$GET(PRC("SITE"))
IF 'SITE
SET SITE=+$GET(^PRCP(445,INVPT,0))
+8 ; Multiple FCP not supported
SET CP=$GET(PRC("CP"))
IF CP=""
SET CP=+$ORDER(^PRC(420,"AE",SITE,INVPT,0))
SET CP=$PIECE($GET(^PRC(420,SITE,1,CP,0))," ")
+9 WRITE !
IF TYPE="W"
Begin DoDot:1
+10 IF MANSRCE'=$ORDER(^PRC(440,"AC","S",0))
WRITE !,"ITEM IS NOT SET UP AS POSTED STOCK. THE MANDATORY SOURCE IN THE ITEM MASTER",!,"FILE DOES NOT EQUAL THE WAREHOUSE VENDOR."
QUIT
+11 SET %=$PIECE($GET(^PRC(440,+$PIECE($GET(^PRC(441,ITEMDA,0)),"^",4),0)),"^")
IF %'=""
WRITE !,"LAST VENDOR ORDERED: ",%
+12 SET %=$PIECE($GET(^PRC(440,+$PIECE($GET(^PRC(441,ITEMDA,4,SITE_CP,0)),"^",3),0)),"^")
IF %'=""
WRITE !,"PREFERRED VENDOR (FOR CP: ",CP,"): ",%
+13 WRITE !,"YOU MAY SELECT ANY VENDOR WHICH IS SET UP AS A VENDOR FOR THIS ITEM IN THE ITEM",!,"MASTER FILE"
+14 WRITE $SELECT(SCREEN:", AND IS A PROCUREMENT SOURCE FOR THIS ITEM IN THE INVENTORY POINT.",1:". ")
if SCREEN
WRITE !
WRITE "THE VENDOR ALSO MUST NOT BE INACTIVATED."
End DoDot:1
WRITE !!
QUIT
+15 IF TYPE="P"
Begin DoDot:1
+16 IF MANSRCE
WRITE !,"ITEM HAS A MANDATORY SOURCE: ",$PIECE($GET(^PRC(440,+MANSRCE,0)),"^"),".",!,"YOU CAN ONLY SELECT THIS VENDOR."
QUIT
+17 SET %=$PIECE($GET(^PRC(440,+$PIECE($GET(^PRC(441,ITEMDA,0)),"^",4),0)),"^")
IF %'=""
WRITE !,"LAST VENDOR ORDERED: ",%
+18 SET %=$PIECE($GET(^PRC(440,+$PIECE($GET(^PRC(441,ITEMDA,4,SITE_CP,0)),"^",3),0)),"^")
IF %'=""
WRITE !,"PREFERRED VENDOR (FOR CP: ",CP,"): ",%
+19 WRITE !,"YOU MAY SELECT ANY VENDOR WHICH IS SET UP AS A VENDOR FOR THIS ITEM IN THE ITEM",!,"MASTER FILE, AND IS A PROCUREMENT SOURCE FOR THIS ITEM IN THE INVENTORY POINT.",!,"THE VENDOR ALSO MUST NOT BE INACTIVATED."
End DoDot:1
WRITE !!
QUIT
+20 IF TYPE="S"
Begin DoDot:1
+21 WRITE !,"YOU CAN ONLY SELECT A PRIMARY DISTRIBUTION POINT WHICH DISTRIBUTES THIS ITEM."
End DoDot:1
WRITE !!
QUIT
+22 QUIT
+23 ;
+24 ;
SCREEN(INVPT,ITEMDA,SCREEN1) ; called from input transform for dd(445.01,.4,
+1 ; x=vendor name, y=vendor number,
+2 ; dic=file 440 or 445 it should lookup on
+3 ; screen1=1 to lookup in screen for procurement source in 445.07
+4 ; if vendor y fails -->> flag=0 and $t=0
+5 NEW %,FLAG,LOOKUP,MANSRCE,SCREEN,TYPE
+6 SET FLAG=1
+7 IF 'INVPT!('ITEMDA)
SET FLAG=0
GOTO END
+8 SET MANSRCE=$$MANDSRCE^PRCPU441(ITEMDA)
SET TYPE=$PIECE($GET(^PRCP(445,INVPT,0)),"^",3)
SET LOOKUP=$SELECT($GET(DIC)["^PRCP(445":";PRCP(445,",1:";PRC(440,")
+9 SET SCREEN="I LOOKUP[440,$D(^PRC(441,ITEMDA,2,+Y)),'$P($G(^PRC(440,+Y,10)),""^"",5)"_$SELECT(SCREEN1:",$O(^PRCP(445,INVPT,1,ITEMDA,5,""B"",(+Y)_"";PRC(440,"",0))",1:"")
+10 IF TYPE="W"
Begin DoDot:1
+11 IF MANSRCE'=$ORDER(^PRC(440,"AC","S",0))
SET FLAG=0
QUIT
+12 IF MANSRCE=Y
SET FLAG=0
QUIT
+13 XECUTE SCREEN
IF '$TEST
SET FLAG=0
End DoDot:1
GOTO END
+14 IF TYPE="P"
Begin DoDot:1
+15 IF MANSRCE
IF Y=MANSRCE
QUIT
+16 IF MANSRCE
SET FLAG=0
QUIT
+17 XECUTE SCREEN
IF '$TEST
SET FLAG=0
End DoDot:1
GOTO END
+18 IF TYPE="S"
Begin DoDot:1
+19 IF LOOKUP[445
IF $DATA(^PRCP(445,Y,1,ITEMDA,0))
IF $DATA(^PRCP(445,Y,2,INVPT,0))
QUIT
+20 SET FLAG=0
End DoDot:1
END IF FLAG
QUIT
+1 IF 0
+2 QUIT
