Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHAMYD

PRCHAMYD.m

Go to the documentation of this file.
  1. PRCHAMYD ;WISC/DJM/DXH - BULLETINS AND UPDATING FILE 441 ; 2/10/00 9:27am
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. OTHER ;NOW TO UPDATE OTHER FILES WITH THE NEW P.O. INFORMATION.
  1. ;
  1. N AUTH,TEST,PONO,VIP,XMB,XMDUZ,USR,XMY,IMF,IMFA,IMF1,IMF2
  1. N OK,TITEM,EE,LL,LOOP,MGR,IP,XMTEXT,PRCPXMY
  1. S IMF=0
  1. F S IMF=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",21,1.5,IMF)) Q:IMF="" D
  1. . S IMF1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,IMF,0)),U,4)
  1. . S IMF2=$P($G(^PRC(442,PRCHPO,2,IMF1,0)),U,5)
  1. . ;
  1. . ; OK, HERE IS THE ITEM MASTER FILE ENTRY FOR THIS
  1. . ; ADDED ITEM. NOW UPDATE ALL THE FIELDS IN THE IMF
  1. . ; ENTRY FOR THIS ITEM THAT FIELD 1.5 BRINGS OVER.
  1. . ;
  1. . D EN3^PRCHCRD3
  1. . Q
  1. K TITEM
  1. S IMF=0
  1. F S IMF=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,IMF)) Q:IMF="" D
  1. . S IMFA=0
  1. . F S IMFA=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,IMF,IMFA)) Q:IMFA="" D
  1. . . S IMF1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,IMFA,0)),U,4)
  1. . . Q:$G(TITEM(IMF1))=1
  1. . . S TITEM(IMF1)=1
  1. . . Q:+$P($G(^PRC(442,PRCHPO,2,IMF1,0)),U,5)=0
  1. . . ;
  1. . . ; NOW, THIS IS AN ITEM THAT HAS BEEN EDITED.
  1. . . ; THE ITEM HASN'T BEEN UPDATED YET AND IT HAS
  1. . . ; AN ITEM MASTER FILE POINTER. LETS UPDATE
  1. . . ; FILE 441 FOR THE ITEM MASTER FILE ENTRY
  1. . . ; FOUND IN THIS ITEM.
  1. . . ;
  1. . . D EN3^PRCHCRD3
  1. . . Q
  1. . Q
  1. ;
  1. ;
  1. LOOKUP ; SEARCH THROUGH FILE 442, NODE 13 FOR 2237s
  1. ;
  1. ; IS THERE ANY 2237s ENTERED FOR THIS P.O.
  1. ;
  1. S LOOP=$G(^PRC(442,PRCHPO,13,0))
  1. Q:LOOP=""
  1. ;
  1. ; NOW FIND OUT IF THERE IS AN INVENTORY POINT IN ANY 2237s
  1. ;
  1. S VIP=0
  1. S LOOP=0
  1. F S LOOP=$O(^PRC(442,PRCHPO,13,LOOP)) Q:LOOP'>0 D
  1. . S IP=$P($G(^PRC(442,PRCHPO,13,LOOP,0)),U,11)
  1. . Q:IP=""
  1. . Q:$$CHECK^PRCPCUT1(IP,1)
  1. . S VIP=1
  1. . D GETUSER^PRCPXTRM(IP)
  1. . Q:$D(PRCPXMY)=0
  1. . S MGR=""
  1. . S USR=0
  1. . F S USR=$O(PRCPXMY(USR)) Q:USR'>0 S:PRCPXMY(USR)=1 XMY(USR)="",MGR=1
  1. . ;
  1. . ; FOUND CONTROL POINT MANAGER/S NOW STOP SEARCHING
  1. . ;
  1. . Q:MGR=1
  1. . ;
  1. . ; LETS SEND TO ALL USERS IN CONTROL POINT THAT CAN USE
  1. . ; INVENTORY POINT
  1. . ;
  1. . S USR=0
  1. . F S USR=$O(PRCPXMY(USR)) Q:USR'>0 S XMY(USR)=""
  1. . Q
  1. ; IF THERE IS A VALID INVENTORY POINT UPDATE ITS DUEINS
  1. ;
  1. I VIP=1 D
  1. . S DA=PRCHPO
  1. . D UPDATE^PRCPWIU
  1. . Q
  1. ;
  1. ; SEE IF THERE ARE ANY USERS LISTED
  1. ;
  1. Q:$O(XMY(0))=""
  1. ;
  1. ; NOW LETS SET UP THE DISPLAY
  1. ;
  1. K ^TMP($J,"AMD"),LINE
  1. ;
  1. ; THIS CALL SETS UP THE DISPLAYED TEXT FOR ANY KIND OF AMENDMENT
  1. ;
  1. D START^PRCHAMY1(PRCHPO,PRCHAM)
  1. ;
  1. ; NOW COMBINE TEXT FROM BULLETIN AND TEXT FROM START^PRCHAMY1
  1. ;
  1. S PONO=$P($G(^PRC(442,PRCHPO,0)),U,1)
  1. S ^TMP($J,"AMD",1,0)=""
  1. S XMTEXT="^TMP($J,""AMD"",1,"
  1. S XMB(1)=PONO
  1. S:$G(IP)>0 XMB(2)=$P(^PRCP(445,IP,0),U)
  1. S XMB="PRC_IFCAP_CHANGE"
  1. S XMDUZ="IFCAP AMENDMENT CHANGE"
  1. W ! ;SPACE FOLLOWING MESSAGE FROM LAST MESSAGE
  1. D EN^XMB
  1. K ^TMP($J,"AMD"),LINE
  1. Q