- 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 Feb 18, 2025@23:32:25 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