125 lines
7.5 KiB
Mathematica
125 lines
7.5 KiB
Mathematica
PRCHITM ;WOIFO/LKG-ITEM UPDATE FROM NIF ;11/15/04 13:02
|
|
V ;;5.1;IFCAP;**63**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
EN ;Entry for server invoked filer
|
|
S PRCERRC=0
|
|
; loading ^XTMP with 888 transaction from MailMan message
|
|
F X XMREC Q:XMER<0!($E(XMRG,1,4)="ISA^")
|
|
I XMER<0 G EXIT
|
|
S PRCTXN=$P(XMRG,U,14)
|
|
S PRCHNODE="PRCHITM;"_PRCTXN K ^XTMP(PRCHNODE)
|
|
; set up ^XTMP header node including automated purge date
|
|
S DT=$$DT^XLFDT,X1=DT,X2=10 D C^%DTC S ^XTMP(PRCHNODE,0)=X_"^"_DT_"^"_"NIF ITEM UPDATE"
|
|
S PRCSUB=1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
|
|
F X XMREC Q:XMER<0!($E(XMRG,1,4)="IEA^") D
|
|
. S PRCSUB=PRCSUB+1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
|
|
I XMER<0 D ERR("IEA segment is missing.") G EXIT
|
|
S PRCSUB=PRCSUB+1,^XTMP(PRCHNODE,1,PRCSUB)=XMRG
|
|
; processing data
|
|
RESTART ;Restart filer with data from ^XTMP global
|
|
S PRCX=$G(^XTMP(PRCHNODE,1,1)) I $P(PRCX,U)'="ISA" D ERR("ISA segment is missing.") G EXIT
|
|
S PRCY=$P(PRCX,U,7) I $TR(PRCY," ")'="36001200NIF" D ERR("Interchange Sender ID '"_PRCY_"' is invalid.") G EXIT
|
|
S PRCY=$P(PRCX,U,9) I $TR(PRCY," ")'="IFCAPNIF" D ERR("Interchange Receiver ID '"_PRCY_"' is invalid.") G EXIT
|
|
S PRCX=$G(^XTMP(PRCHNODE,1,2)) I $P(PRCX,U)'="ST" D ERR("ST segment is missing.") G EXIT
|
|
I $P(PRCX,U,2)'="888" D ERR("Transaction is not the 888.") G EXIT
|
|
S PRCX=$G(^XTMP(PRCHNODE,1,3)) I $P(PRCX,U)'="N1" D ERR("N1 segment is missing.") G EXIT
|
|
I $P(PRCX,U,3)'="NIF" D ERR("Source is not the National Item File database.") G EXIT
|
|
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
|
|
I $P(PRCX,U,7)'="KA" D ERR("Intended recipient application is not IFCAP's ITEM MASTER file.") G EXIT
|
|
S PRCSUB=6 I $P($G(^XTMP(PRCHNODE,1,PRCSUB)),U)'="G39" D ERR("Item characteristics node 'G39' is missing.") G EXIT
|
|
PROCITM ;Process items
|
|
S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB))
|
|
I $P(PRCX,U,24)'="ZZ" D ERR("The G39 segment for NIF Item #"_$P(PRCX,U,25)_" is defective.") G EXIT
|
|
S PRCIEN=$P(PRCX,U,4),PRCNIF=$P(PRCX,U,25)
|
|
I PRCNIF?1.N D
|
|
. I PRCIEN?1.N D
|
|
. . ; updating IMF entry specified by IMF Number in G39 segment
|
|
. . I '$$FIND1^DIC(441,"","XQ","`"_PRCIEN,"","","PRCE") D ERR("Item Master Number "_PRCIEN_" does not exist.") Q
|
|
. . 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
|
|
. . S PRCLOCK=0 F PRCI=1:1:20 L +^PRC(441,PRCIEN):30 I $T S PRCLOCK=1 Q
|
|
. . I 'PRCLOCK D ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".") Q
|
|
. . ; filing NIF Item #
|
|
. . K PRCRR,PRCE S PRCRR(441,PRCIEN_",",51)=PRCNIF D FILE^DIE("E","PRCRR","PRCE")
|
|
. . 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))
|
|
. . K PRCRR,PRCE
|
|
. . S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB))
|
|
. . I PRCSUB="" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") L -^PRC(441,PRCIEN) Q
|
|
. . D DESC(PRCIEN,1) L -^PRC(441,PRCIEN)
|
|
. . I $O(^PRCP(445,"AH",PRCIEN,""))]"" D BLDSEG^PRCPHLFM(3,PRCIEN,0) ;update supply stations
|
|
. I PRCIEN'?1.N D
|
|
. . ; updating all IMF entries with specified NIF Item Number
|
|
. . K PRCE,PRCRR
|
|
. . D FIND^DIC(441,"","@","XQ",PRCNIF,"","I","","","PRCRR","PRCE")
|
|
. . I '$D(PRCRR("DILIST",2)) D ERR("No entry was found with NIF Item #"_PRCNIF_".") Q
|
|
. . S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)),PRCZ=PRCSUB
|
|
. . I PRCSUB="" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") Q
|
|
. . K PRCL M PRCL=PRCRR("DILIST",2) ; save list of iens
|
|
. . S PRCCTR=0 F S PRCCTR=$O(PRCL(PRCCTR)) Q:PRCCTR="" D
|
|
. . . S PRCIEN=PRCL(PRCCTR)
|
|
. . . 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
|
|
. . . S PRCLOCK=0 F PRCI=1:1:20 L +^PRC(441,PRCIEN):30 I $T S PRCLOCK=1 Q
|
|
. . . I 'PRCLOCK D ERR("Filer was unable to lock Item Master Number "_PRCIEN_"/NIF Item #"_PRCNIF_".") Q
|
|
. . . S PRCSUB=PRCZ D DESC(PRCIEN,0) L -^PRC(441,PRCIEN)
|
|
. . . I $O(^PRCP(445,"AH",PRCIEN,""))]"" D BLDSEG^PRCPHLFM(3,PRCIEN,0) ;update supply stations
|
|
. . K PRCRR,PRCE,PRCL,PRCZ
|
|
I PRCNIF'?1.N D ERR("NIF Item Number is missing for Item Master Number "_PRCIEN_".")
|
|
NEXT F S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)) Q:PRCSUB="" S PRCX=$G(^(PRCSUB)) Q:"^G39^SE^"[("^"_$P(PRCX,U)_"^")
|
|
G PROCITM:$P(PRCX,U)="G39"
|
|
EXIT I $D(PRCHNODE) D
|
|
. ; send message if errors
|
|
. I $D(^XTMP(PRCHNODE,"ERR")) D
|
|
. . N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
|
|
. . S XMSUB="Item Filing Errors for Interchange Control #"_PRCTXN
|
|
. . S XMDUZ="Master Item File Updater",XMTEXT="^XTMP(PRCHNODE,""ERR"","
|
|
. . S XMY("G.ISM")="",XMY("Lyford.Greene@med.va.gov")=""
|
|
. . D ^XMD
|
|
. ; if no errors delete ^XTMP nodes when done
|
|
. I '$D(^XTMP(PRCHNODE,"ERR")) K ^XTMP(PRCHNODE)
|
|
K PRCCTR,PRCE,PRCERRC,PRCI,PRCIEN,PRCL,PRCLOCK,PRCNIF,PRCHNODE,PRCRR,PRCSUB,PRCTXN,PRCX,PRCY,PRCZ,XMPOS,X,X1,X2,XMER,XMREC,XMRG,Y
|
|
; delete MailMan message from server basket
|
|
I $D(XMZ) S XMSER="S."_XQSOP D REMSBMSG^XMA1C
|
|
Q
|
|
DESC(PRCDA,PRCFLG) ;File Short and Extended Descriptions
|
|
N PRCDES
|
|
S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB))
|
|
I $P(PRCX,U)'="G69" D ERR("No descriptions exist for NIF Item Number "_PRCNIF_".") Q
|
|
S X=$P(PRCX,U,2) X ^%ZOSF("UPPERCASE") S PRCDES=Y
|
|
I PRCDES'="" D
|
|
. ; file NIF version of short description, but first save off
|
|
. I PRCFLG,$L($P($G(^PRC(441,PRCDA,9)),"^"))=0 D I $D(PRCE("DIERR")) K PRCE,PRCRR Q
|
|
. . N PRCDESO S PRCDESO=$P($G(^PRC(441,PRCDA,0)),"^",2)
|
|
. . K PRCRR,PRCE S PRCRR(441,PRCDA_",",52)=PRCDESO
|
|
. . D FILE^DIE("E","PRCRR","PRCE")
|
|
. . 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))
|
|
. . I $D(PRCE("DIERR")) K PRCRR Q
|
|
. . K PRCRR,PRCERR S PRCDESO=$E(PRCDESO,1,36)
|
|
. . I '$$FIND1^DIC(441.05,","_PRCDA_",","X",PRCDESO,"","","PRCE") D
|
|
. . . S PRCRR(441.05,"+1,"_PRCDA_",",.01)=PRCDESO D UPDATE^DIE("E","PRCRR","","PRCERR")
|
|
. . . 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))
|
|
. . . K PRCRR,PRCERR
|
|
. K PRCRR,PRCE S PRCRR(441,PRCDA_",",.05)=PRCDES D FILE^DIE("E","PRCRR","PRCE")
|
|
. 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))
|
|
. K PRCRR,PRCE
|
|
; save off prior description during first NIF import
|
|
; if save fails, don't overwrite existing description with NIF extended description
|
|
I PRCFLG,$P($G(^PRC(441,PRCDA,8,0)),U,4)'>0 D I $D(PRCE("DIERR")) K PRCE Q
|
|
. K PRCE D WP^DIE(441,PRCDA_",",50,"","^PRC(441,PRCDA,1)","PRCE")
|
|
. 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))
|
|
; extract extended description
|
|
S PRCI=0 K PRCY
|
|
F S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB)) Q:PRCSUB="" S PRCX=$G(^XTMP(PRCHNODE,1,PRCSUB)) Q:$P(PRCX,U)'="G69" D
|
|
. S PRCI=PRCI+1,PRCY(PRCI)=$P($G(^XTMP(PRCHNODE,1,PRCSUB)),U,2)
|
|
I PRCI'>0 D ERR("No extended description exists for NIF Item Number "_PRCNIF_".")
|
|
I PRCI D
|
|
. ; file NIF extended description in description field
|
|
. K PRCE D WP^DIE(441,PRCDA_",",.1,"","PRCY","PRCE")
|
|
. K PRCY
|
|
. 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))
|
|
. K PRCE
|
|
S PRCSUB=$O(^XTMP(PRCHNODE,1,PRCSUB),-1)
|
|
Q
|
|
ERR(PRCMSG) ;Error processing
|
|
S PRCERRC=PRCERRC+1 S ^XTMP(PRCHNODE,"ERR",PRCERRC)=PRCMSG
|
|
Q
|