source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHITM.m@ 1314

Last change on this file since 1314 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.5 KB
Line 
1PRCHITM ;WOIFO/LKG-ITEM UPDATE FROM NIF ;11/15/04 13:02
2V ;;5.1;IFCAP;**63**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5EN ;Entry for server invoked filer
6 S PRCERRC=0
7 ; loading ^XTMP with 888 transaction from MailMan message
8 F X XMREC Q:XMER<0!($E(XMRG,1,4)="ISA^")
9 I XMER<0 G EXIT
10 S PRCTXN=$P(XMRG,U,14)
11 S PRCHNODE="PRCHITM;"_PRCTXN K ^XTMP(PRCHNODE)
12 ; set up ^XTMP header node including automated purge date
13 S DT=$$DT^XLFDT,X1=DT,X2=10 D C^%DTC S ^XTMP(PRCHNODE,0)=X_"^"_DT_"^"_"NIF ITEM UPDATE"
14 S PRCSUB=1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
15 F X XMREC Q:XMER<0!($E(XMRG,1,4)="IEA^") D
16 . S PRCSUB=PRCSUB+1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
17 I XMER<0 D ERR("IEA segment is missing.") G EXIT
18 S PRCSUB=PRCSUB+1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
19 ; processing data
20RESTART ;Restart filer with data from ^XTMP global
21 S PRCX=$G(^XTMP(PRCHNODE,1,1)) I $P(PRCX,U)'="ISA" D ERR("ISA segment is missing.") G EXIT
22 S PRCY=$P(PRCX,U,7) I $TR(PRCY," ")'="36001200NIF" D ERR("Interchange Sender ID '"_PRCY_"' is invalid.") G EXIT
23 S PRCY=$P(PRCX,U,9) I $TR(PRCY," ")'="IFCAPNIF" D ERR("Interchange Receiver ID '"_PRCY_"' is invalid.") G EXIT
24 S PRCX=$G(^XTMP(PRCHNODE,1,2)) I $P(PRCX,U)'="ST" D ERR("ST segment is missing.") G EXIT
25 I $P(PRCX,U,2)'="888" D ERR("Transaction is not the 888.") G EXIT
26 S PRCX=$G(^XTMP(PRCHNODE,1,3)) I $P(PRCX,U)'="N1" D ERR("N1 segment is missing.") G EXIT
27 I $P(PRCX,U,3)'="NIF" D ERR("Source is not the National Item File database.") G EXIT
28 S Y=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99) I $P(PRCX,U,5)'=Y D ERR("Intended recipient station is "_$P(PRCX,U,5)_", not "_Y_".") G EXIT
29 I $P(PRCX,U,7)'="KA" D ERR("Intended recipient application is not IFCAP's ITEM MASTER file.") G EXIT
30 S PRCSUB=6 I $P($G(^XTMP(PRCHNODE,1,PRCSUB)),U)'="G39" D ERR("Item characteristics node 'G39' is missing.") G EXIT
31PROCITM ;Process items
32 S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB))
33 I $P(PRCX,U,24)'="ZZ" D ERR("The G39 segment for NIF Item #"_$P(PRCX,U,25)_" is defective.") G EXIT
34 S PRCIEN=$P(PRCX,U,4),PRCNIF=$P(PRCX,U,25)
35 I PRCNIF?1.N D
36 . I PRCIEN?1.N D
37 . . ; updating IMF entry specified by IMF Number in G39 segment
38 . . I '$$FIND1^DIC(441,"","XQ","`"_PRCIEN,"","","PRCE") D ERR("Item Master Number "_PRCIEN_" does not exist.") Q
39 . . K PRCE I $$GET1^DIQ(441,PRCIEN_",",16,"I","","PRCE") D ERR("Item Master Number "_PRCIEN_" is inactive, so it will not be updated.") Q
40 . . S PRCLOCK=0 F PRCI=1:1:20 L +^PRC(441,PRCIEN):30 I $T S PRCLOCK=1 Q
41 . . I 'PRCLOCK D ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".") Q
42 . . ; filing NIF Item #
43 . . K PRCRR,PRCE S PRCRR(441,PRCIEN_",",51)=PRCNIF D FILE^DIE("E","PRCRR","PRCE")
44 . . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCIEN_": "_PRCE("DIERR",1,"TEXT",PRCY))
45 . . K PRCRR,PRCE
46 . . S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB))
47 . . I PRCSUB="" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") L -^PRC(441,PRCIEN) Q
48 . . D DESC(PRCIEN,1) L -^PRC(441,PRCIEN)
49 . . I $O(^PRCP(445,"AH",PRCIEN,""))]"" D BLDSEG^PRCPHLFM(3,PRCIEN,0) ;update supply stations
50 . I PRCIEN'?1.N D
51 . . ; updating all IMF entries with specified NIF Item Number
52 . . K PRCE,PRCRR
53 . . D FIND^DIC(441,"","@","XQ",PRCNIF,"","I","","","PRCRR","PRCE")
54 . . I '$D(PRCRR("DILIST",2)) D ERR("No entry was found with NIF Item #"_PRCNIF_".") Q
55 . . S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)),PRCZ=PRCSUB
56 . . I PRCSUB="" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") Q
57 . . K PRCL M PRCL=PRCRR("DILIST",2) ; save list of iens
58 . . S PRCCTR=0 F S PRCCTR=$O(PRCL(PRCCTR)) Q:PRCCTR="" D
59 . . . S PRCIEN=PRCL(PRCCTR)
60 . . . K PRCE I $$GET1^DIQ(441,PRCIEN_",",16,"I","","PRCE") D ERR("Item Master Number "_PRCIEN_" is inactive, so it will not be updated.") Q
61 . . . S PRCLOCK=0 F PRCI=1:1:20 L +^PRC(441,PRCIEN):30 I $T S PRCLOCK=1 Q
62 . . . I 'PRCLOCK D ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".") Q
63 . . . S PRCSUB=PRCZ D DESC(PRCIEN,0) L -^PRC(441,PRCIEN)
64 . . . I $O(^PRCP(445,"AH",PRCIEN,""))]"" D BLDSEG^PRCPHLFM(3,PRCIEN,0) ;update supply stations
65 . . K PRCRR,PRCE,PRCL,PRCZ
66 I PRCNIF'?1.N D ERR("NIF Item Number is missing for Item Master Number "_PRCIEN_".")
67NEXT F S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)) Q:PRCSUB="" S PRCX=$G(^(PRCSUB)) Q:"^G39^SE^"[("^"_$P(PRCX,U)_"^")
68 G PROCITM:$P(PRCX,U)="G39"
69EXIT I $D(PRCHNODE) D
70 . ; send message if errors
71 . I $D(^XTMP(PRCHNODE,"ERR")) D
72 . . N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
73 . . S XMSUB="Item Filing Errors for Interchange Control #"_PRCTXN
74 . . S XMDUZ="Master Item File Updater",XMTEXT="^XTMP(PRCHNODE,""ERR"","
75 . . S XMY("G.ISM")="",XMY("Lyford.Greene@med.va.gov")=""
76 . . D ^XMD
77 . ; if no errors delete ^XTMP nodes when done
78 . I '$D(^XTMP(PRCHNODE,"ERR")) K ^XTMP(PRCHNODE)
79 K PRCCTR,PRCE,PRCERRC,PRCI,PRCIEN,PRCL,PRCLOCK,PRCNIF,PRCHNODE,PRCRR,PRCSUB,PRCTXN,PRCX,PRCY,PRCZ,XMPOS,X,X1,X2,XMER,XMREC,XMRG,Y
80 ; delete MailMan message from server basket
81 I $D(XMZ) S XMSER="S."_XQSOP D REMSBMSG^XMA1C
82 Q
83DESC(PRCDA,PRCFLG) ;File Short and Extended Descriptions
84 N PRCDES
85 S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB))
86 I $P(PRCX,U)'="G69" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") Q
87 S X=$P(PRCX,U,2) X ^%ZOSF("UPPERCASE") S PRCDES=Y
88 I PRCDES'="" D
89 . ; file NIF version of short description, but first save off
90 . I PRCFLG,$L($P($G(^PRC(441,PRCDA,9)),"^"))=0 D I $D(PRCE("DIERR")) K PRCE,PRCRR Q
91 . . N PRCDESO S PRCDESO=$P($G(^PRC(441,PRCDA,0)),"^",2)
92 . . K PRCRR,PRCE S PRCRR(441,PRCDA_",",52)=PRCDESO
93 . . D FILE^DIE("E","PRCRR","PRCE")
94 . . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
95 . . I $D(PRCE("DIERR")) K PRCRR Q
96 . . K PRCRR,PRCERR S PRCDESO=$E(PRCDESO,1,36)
97 . . I '$$FIND1^DIC(441.05,","_PRCDA_",","X",PRCDESO,"","","PRCE") D
98 . . . S PRCRR(441.05,"+1,"_PRCDA_",",.01)=PRCDESO D UPDATE^DIE("E","PRCRR","","PRCERR")
99 . . . I $D(PRCERR("DIERR")) S PRCY=0 F S PRCY=$O(PRCERR("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCERR("DIERR",1,"TEXT",PRCY))
100 . . . K PRCRR,PRCERR
101 . K PRCRR,PRCE S PRCRR(441,PRCDA_",",.05)=PRCDES D FILE^DIE("E","PRCRR","PRCE")
102 . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
103 . K PRCRR,PRCE
104 ; save off prior description during first NIF import
105 ; if save fails, don't overwrite existing description with NIF extended description
106 I PRCFLG,$P($G(^PRC(441,PRCDA,8,0)),U,4)'>0 D I $D(PRCE("DIERR")) K PRCE Q
107 . K PRCE D WP^DIE(441,PRCDA_",",50,"","^PRC(441,PRCDA,1)","PRCE")
108 . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
109 ; extract extended description
110 S PRCI=0 K PRCY
111 F S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)) Q:PRCSUB="" S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB)) Q:$P(PRCX,U)'="G69" D
112 . S PRCI=PRCI+1,PRCY(PRCI)=$P($G(^XTMP(PRCHNODE,1,PRCSUB)),U,2)
113 I PRCI'>0 D ERR("No extended description exists for NIF Item Number "_PRCNIF_".")
114 I PRCI D
115 . ; file NIF extended description in description field
116 . K PRCE D WP^DIE(441,PRCDA_",",.1,"","PRCY","PRCE")
117 . K PRCY
118 . I $D(PRCE("DIERR")) S PRCY=0 F S PRCY=$O(PRCE("DIERR",1,"TEXT",PRCY)) Q:PRCY'>0 D ERR("Item Master Number "_PRCDA_": "_PRCE("DIERR",1,"TEXT",PRCY))
119 . K PRCE
120 S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB),-1)
121 Q
122ERR(PRCMSG) ;Error processing
123 S PRCERRC=PRCERRC+1 S ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG
124 Q
Note: See TracBrowser for help on using the repository browser.