PRCHAMYD ;WISC/DJM/DXH - BULLETINS AND UPDATING FILE 441 ; 2/10/00 9:27am
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
OTHER ;NOW TO UPDATE OTHER FILES WITH THE NEW P.O. INFORMATION.
;
N AUTH,TEST,PONO,VIP,XMB,XMDUZ,USR,XMY,IMF,IMFA,IMF1,IMF2
N OK,TITEM,EE,LL,LOOP,MGR,IP,XMTEXT,PRCPXMY
S IMF=0
F S IMF=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",21,1.5,IMF)) Q:IMF="" D
. S IMF1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,IMF,0)),U,4)
. S IMF2=$P($G(^PRC(442,PRCHPO,2,IMF1,0)),U,5)
. ;
. ; OK, HERE IS THE ITEM MASTER FILE ENTRY FOR THIS
. ; ADDED ITEM. NOW UPDATE ALL THE FIELDS IN THE IMF
. ; ENTRY FOR THIS ITEM THAT FIELD 1.5 BRINGS OVER.
. ;
. D EN3^PRCHCRD3
. Q
K TITEM
S IMF=0
F S IMF=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,IMF)) Q:IMF="" D
. S IMFA=0
. F S IMFA=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,IMF,IMFA)) Q:IMFA="" D
. . S IMF1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,IMFA,0)),U,4)
. . Q:$G(TITEM(IMF1))=1
. . S TITEM(IMF1)=1
. . Q:+$P($G(^PRC(442,PRCHPO,2,IMF1,0)),U,5)=0
. . ;
. . ; NOW, THIS IS AN ITEM THAT HAS BEEN EDITED.
. . ; THE ITEM HASN'T BEEN UPDATED YET AND IT HAS
. . ; AN ITEM MASTER FILE POINTER. LETS UPDATE
. . ; FILE 441 FOR THE ITEM MASTER FILE ENTRY
. . ; FOUND IN THIS ITEM.
. . ;
. . D EN3^PRCHCRD3
. . Q
. Q
;
;
LOOKUP ; SEARCH THROUGH FILE 442, NODE 13 FOR 2237s
;
; IS THERE ANY 2237s ENTERED FOR THIS P.O.
;
S LOOP=$G(^PRC(442,PRCHPO,13,0))
Q:LOOP=""
;
; NOW FIND OUT IF THERE IS AN INVENTORY POINT IN ANY 2237s
;
S VIP=0
S LOOP=0
F S LOOP=$O(^PRC(442,PRCHPO,13,LOOP)) Q:LOOP'>0 D
. S IP=$P($G(^PRC(442,PRCHPO,13,LOOP,0)),U,11)
. Q:IP=""
. Q:$$CHECK^PRCPCUT1(IP,1)
. S VIP=1
. D GETUSER^PRCPXTRM(IP)
. Q:$D(PRCPXMY)=0
. S MGR=""
. S USR=0
. F S USR=$O(PRCPXMY(USR)) Q:USR'>0 S:PRCPXMY(USR)=1 XMY(USR)="",MGR=1
. ;
. ; FOUND CONTROL POINT MANAGER/S NOW STOP SEARCHING
. ;
. Q:MGR=1
. ;
. ; LETS SEND TO ALL USERS IN CONTROL POINT THAT CAN USE
. ; INVENTORY POINT
. ;
. S USR=0
. F S USR=$O(PRCPXMY(USR)) Q:USR'>0 S XMY(USR)=""
. Q
; IF THERE IS A VALID INVENTORY POINT UPDATE ITS DUEINS
;
I VIP=1 D
. S DA=PRCHPO
. D UPDATE^PRCPWIU
. Q
;
; SEE IF THERE ARE ANY USERS LISTED
;
Q:$O(XMY(0))=""
;
; NOW LETS SET UP THE DISPLAY
;
K ^TMP($J,"AMD"),LINE
;
; THIS CALL SETS UP THE DISPLAYED TEXT FOR ANY KIND OF AMENDMENT
;
D START^PRCHAMY1(PRCHPO,PRCHAM)
;
; NOW COMBINE TEXT FROM BULLETIN AND TEXT FROM START^PRCHAMY1
;
S PONO=$P($G(^PRC(442,PRCHPO,0)),U,1)
S ^TMP($J,"AMD",1,0)=""
S XMTEXT="^TMP($J,""AMD"",1,"
S XMB(1)=PONO
S:$G(IP)>0 XMB(2)=$P(^PRCP(445,IP,0),U)
S XMB="PRC_IFCAP_CHANGE"
S XMDUZ="IFCAP AMENDMENT CHANGE"
W ! ;SPACE FOLLOWING MESSAGE FROM LAST MESSAGE
D EN^XMB
K ^TMP($J,"AMD"),LINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMYD 3001 printed Dec 13, 2024@02:06:01 Page 2
PRCHAMYD ;WISC/DJM/DXH - BULLETINS AND UPDATING FILE 441 ; 2/10/00 9:27am
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
OTHER ;NOW TO UPDATE OTHER FILES WITH THE NEW P.O. INFORMATION.
+1 ;
+2 NEW AUTH,TEST,PONO,VIP,XMB,XMDUZ,USR,XMY,IMF,IMFA,IMF1,IMF2
+3 NEW OK,TITEM,EE,LL,LOOP,MGR,IP,XMTEXT,PRCPXMY
+4 SET IMF=0
+5 FOR
SET IMF=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",21,1.5,IMF))
if IMF=""
QUIT
Begin DoDot:1
+6 SET IMF1=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,3,IMF,0)),U,4)
+7 SET IMF2=$PIECE($GET(^PRC(442,PRCHPO,2,IMF1,0)),U,5)
+8 ;
+9 ; OK, HERE IS THE ITEM MASTER FILE ENTRY FOR THIS
+10 ; ADDED ITEM. NOW UPDATE ALL THE FIELDS IN THE IMF
+11 ; ENTRY FOR THIS ITEM THAT FIELD 1.5 BRINGS OVER.
+12 ;
+13 DO EN3^PRCHCRD3
+14 QUIT
End DoDot:1
+15 KILL TITEM
+16 SET IMF=0
+17 FOR
SET IMF=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,IMF))
if IMF=""
QUIT
Begin DoDot:1
+18 SET IMFA=0
+19 FOR
SET IMFA=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,IMF,IMFA))
if IMFA=""
QUIT
Begin DoDot:2
+20 SET IMF1=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,3,IMFA,0)),U,4)
+21 if $GET(TITEM(IMF1))=1
QUIT
+22 SET TITEM(IMF1)=1
+23 if +$PIECE($GET(^PRC(442,PRCHPO,2,IMF1,0)),U,5)=0
QUIT
+24 ;
+25 ; NOW, THIS IS AN ITEM THAT HAS BEEN EDITED.
+26 ; THE ITEM HASN'T BEEN UPDATED YET AND IT HAS
+27 ; AN ITEM MASTER FILE POINTER. LETS UPDATE
+28 ; FILE 441 FOR THE ITEM MASTER FILE ENTRY
+29 ; FOUND IN THIS ITEM.
+30 ;
+31 DO EN3^PRCHCRD3
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 ;
+35 ;
LOOKUP ; SEARCH THROUGH FILE 442, NODE 13 FOR 2237s
+1 ;
+2 ; IS THERE ANY 2237s ENTERED FOR THIS P.O.
+3 ;
+4 SET LOOP=$GET(^PRC(442,PRCHPO,13,0))
+5 if LOOP=""
QUIT
+6 ;
+7 ; NOW FIND OUT IF THERE IS AN INVENTORY POINT IN ANY 2237s
+8 ;
+9 SET VIP=0
+10 SET LOOP=0
+11 FOR
SET LOOP=$ORDER(^PRC(442,PRCHPO,13,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+12 SET IP=$PIECE($GET(^PRC(442,PRCHPO,13,LOOP,0)),U,11)
+13 if IP=""
QUIT
+14 if $$CHECK^PRCPCUT1(IP,1)
QUIT
+15 SET VIP=1
+16 DO GETUSER^PRCPXTRM(IP)
+17 if $DATA(PRCPXMY)=0
QUIT
+18 SET MGR=""
+19 SET USR=0
+20 FOR
SET USR=$ORDER(PRCPXMY(USR))
if USR'>0
QUIT
if PRCPXMY(USR)=1
SET XMY(USR)=""
SET MGR=1
+21 ;
+22 ; FOUND CONTROL POINT MANAGER/S NOW STOP SEARCHING
+23 ;
+24 if MGR=1
QUIT
+25 ;
+26 ; LETS SEND TO ALL USERS IN CONTROL POINT THAT CAN USE
+27 ; INVENTORY POINT
+28 ;
+29 SET USR=0
+30 FOR
SET USR=$ORDER(PRCPXMY(USR))
if USR'>0
QUIT
SET XMY(USR)=""
+31 QUIT
End DoDot:1
+32 ; IF THERE IS A VALID INVENTORY POINT UPDATE ITS DUEINS
+33 ;
+34 IF VIP=1
Begin DoDot:1
+35 SET DA=PRCHPO
+36 DO UPDATE^PRCPWIU
+37 QUIT
End DoDot:1
+38 ;
+39 ; SEE IF THERE ARE ANY USERS LISTED
+40 ;
+41 if $ORDER(XMY(0))=""
QUIT
+42 ;
+43 ; NOW LETS SET UP THE DISPLAY
+44 ;
+45 KILL ^TMP($JOB,"AMD"),LINE
+46 ;
+47 ; THIS CALL SETS UP THE DISPLAYED TEXT FOR ANY KIND OF AMENDMENT
+48 ;
+49 DO START^PRCHAMY1(PRCHPO,PRCHAM)
+50 ;
+51 ; NOW COMBINE TEXT FROM BULLETIN AND TEXT FROM START^PRCHAMY1
+52 ;
+53 SET PONO=$PIECE($GET(^PRC(442,PRCHPO,0)),U,1)
+54 SET ^TMP($JOB,"AMD",1,0)=""
+55 SET XMTEXT="^TMP($J,""AMD"",1,"
+56 SET XMB(1)=PONO
+57 if $GET(IP)>0
SET XMB(2)=$PIECE(^PRCP(445,IP,0),U)
+58 SET XMB="PRC_IFCAP_CHANGE"
+59 SET XMDUZ="IFCAP AMENDMENT CHANGE"
+60 ;SPACE FOLLOWING MESSAGE FROM LAST MESSAGE
WRITE !
+61 DO EN^XMB
+62 KILL ^TMP($JOB,"AMD"),LINE
+63 QUIT
