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

PSNPPSNU.m

Go to the documentation of this file.
  1. PSNPPSNU ;HP/MJE-PPSN update NDF data ; 05 Mar 2014 1:20 PM
  1. ;;4.0;NATIONAL DRUG FILE;**513,563,566,569**; 30 Oct 98;Build 3
  1. ;Reference to ^PSDRUG supported by DBIA #2192
  1. ;Reference to PSN^PSSHUIDG supported by DBIA #3621
  1. ;Reference to ^GMR(120.8) supported by DBIA #4606
  1. ;Reference to ^DD supported by DBIA #1258
  1. ;Reference to ^PSSUTIL supported by DBIA #3107
  1. ;
  1. ; Note: this routine is an adapted version of the origional code by Dr. Dave Alexander
  1. ;
  1. N CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K
  1. N LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
  1. N X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,TREC,PSNMULTI,MJJ,PSNERROR
  1. N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,XPATH
  1. N PSNPS,XPDIDTOT,RES1,PSNTMPN
  1. K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$J),^TMP("PSN PPSN.WP",$J),^TMP("PSN PPSN ERR",$J),^TMP("PSNINGRED",$J)
  1. ;
  1. ;SETUP PRODUCTION OR SQA
  1. S PSNPS=$P($G(^PS(59.7,1,10)),"^",12),PSNERROR=0
  1. I PSNPS="T"!(PSNPS="S") S PSNPS="P" ;test account and support account is same as production.
  1. S PSNDF=1,XPDIDTOT=+$G(^TMP("PSN PPSN PARSED",$J,"TREC")),TREC=0
  1. ;TO ALLOW ADDS TO 56,50.416,50.605,50.606, AND 50.6
  1. ;
  1. D DATANT^PSNPPSI1
  1. I PSNPS="N" D POSTRUN^PSNPPSNK
  1. ;
  1. WORD ;
  1. D CTRKDL^PSNPPSMS("Storing report messages information")
  1. S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="WORD"
  1. D UPDATE^DIE("","FDA","CTRLIEN")
  1. K FDA
  1. S ROOT1=$NA(^TMP("PSN PPSN PARSED",$J,"WORD")),CT=0,ROOT2=$NA(@ROOT1@(0))
  1. F S CT=$O(@ROOT2) Q:'CT D CTRLSS^PSNPPSMS(CT) S ROOT2=$NA(@ROOT1@(CT)),NAME=@ROOT2,ROOT3=$NA(@ROOT2@("D")) K @NAME M @NAME=@ROOT3
  1. ;
  1. D CTRKDL^PSNPPSMS("Sending mail messages")
  1. D MESSAGE^PSNPPSMG
  1. ;
  1. D CTRKDL^PSNPPSMS("Beginning un-march/re-match")
  1. W:'$G(PSNSCJOB) !,"Beginning un-match/re-match to local drug file...",!
  1. DRUGFILE ;
  1. ;NOW UPDATE LOCAL DRUG FILE
  1. N REM,PSNUNMAT
  1. K ^TMP($J)
  1. I PSNPS="N" S OLDNDF="" F S OLDNDF=$O(^TMP("PSN PPSN PARSED",$J,"REM",OLDNDF)) Q:OLDNDF="" D EN1^PSNPPSNW(OLDNDF,"")
  1. S OLDNDF="",PSN=$$PATCH^XPDUTL("PSS*1.0*34"),PSN1=$$PATCH^XPDUTL("PSS*1.0*42")
  1. S ROOT2=$NA(^TMP("PSN PPSN PARSED",$J,"PRODUCTS TO UNMATCH")),ROOT3=$NA(^TMP("PSN PPSN PARSED",$J,"POE")),DA=0
  1. S DA=0 F S DA=$O(^PSDRUG(DA)) Q:'DA S X=$G(^PSDRUG(DA,0)) I X]"" S NA=$P(X,"^"),CLA=$P(X,"^",2),INV=$P(X,"^",3)["I",X=$G(^("ND")),IN=$P($G(^("I"),9999999),"^"),INA=IN'>DT,GE=+X,PR=+$P(X,"^",3),CMOP=$P(X,"^",10),VAPN=$P(X,"^",2) I GE I PR D
  1. .S OLDNDF=$P($G(^PSDRUG(DA,"ND")),"^",3) ;va product name (3P:50.68); NA = generic name; CLA = VA Class; INV = DEA Special HDLG
  1. .S VAIN=$P($G(^PSNDF(50.68,PR,7)),"^",3) ;inactivation date
  1. .I $D(@ROOT2@(PR))!VAIN S X="" S:CMOP]"" X=" (CMOP "_CMOP_")" D
  1. ..S $E(X,30)=VAPN,$E(X,65)=$$FMTE^XLFDT(VAIN,5),INDX=$S(INA:"I",INV:"X",1:"A")
  1. ..S:IN=9999999 IN="" S ^TMP($J,INDX,NA_"^"_DA_"^"_IN,1)=X,^TMP($J,"^",DA)=""
  1. ..D UNMDRUG^PSSUTIL(DA)
  1. ..I PSN I $P($G(^PSDRUG(DA,"DOS")),"^")]""!$O(^("DOS1",0))!$O(^PSDRUG(DA,"DOS2",0)) D LOAD^PSNPPSNV K ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
  1. ..I $P($G(^PSDRUG(DA,3)),"^") S DIE=50,DR="213////0;" D ^DIE D ERROR:$D(ERROR("DIERR")) K DIE,DR I PSN1 S IND=$O(^PSDRUG(DA,4," "),-1),$P(^(IND,0),"^",6)="NDF Update"
  1. .;check here if PR (50.68 IEN this local drug is matched to) exists in TMP rematch
  1. .;if a re-match for that IEN is not null, do re-match (file re-match, add to report)
  1. .S REM="" I OLDNDF'="" S REM=$G(^TMP("PSN PPSN PARSED",$J,"REM",OLDNDF))
  1. .I REM'="" D REMATCH^PSNPPSNW(DA,REM)
  1. .I PSN,$D(@ROOT3@(PR)) K ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
  1. .S ND=$G(^PSDRUG(DA,"ND")),PR=$P(ND,"^",3) I PR D
  1. ..S NFI=$P($G(^PSNDF(50.68,PR,5)),"^") I $P(ND,"^",11)'=NFI S DIE=50,DR="29////"_NFI_";" D ^DIE D ERROR:$D(ERROR("DIERR"))
  1. ..S VAC=$P($G(^PSNDF(50.68,PR,3)),"^") I VAC S VAC=$P(^PS(50.605,VAC,0),"^"),DIE=50,DR="2////"_VAC_";" D ^DIE D ERROR:$D(ERROR("DIERR"))
  1. ..I $P($G(^PSDRUG(DA,3)),"^"),'$P($G(^PSNDF(50.68,PR,1)),"^",3) S DIE=50,DR="213////0;" D ^DIE D ERROR:$D(ERROR("DIERR")) K DIE,DR S IND=$O(^PSDRUG(DA,4," "),-1),$P(^(IND,0),"^",6)="NDF Update"
  1. .;S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
  1. D DRGMSG^PSNPPSMG
  1. ;package specific post install
  1. I $D(^TMP("PSN PPSN PARSED",$J,"POST")) S POST=^("POST") S:POST'["^" POST="^"_POST I @("$T("_POST_")]]""""") D @POST
  1. ;
  1. ;call to HL7 drug update message
  1. I $T(PSN^PSSHUIDG)]"" I $O(^TMP($J,"^",0)) S ZTRTN="PSN^PSSHUIDG",ZTIO="",ZTDTH=$H,ZTDESC="DRUG UPDATE MESSAGE",ZTSAVE("^TMP($J,""^"",")="" D ^%ZTLOAD
  1. ;
  1. D CTRKDL^PSNPPSMS("Validating cross references")
  1. W:'$G(PSNSCJOB) !,"Validating cross references...",!
  1. REINDEX ;Make sure APC xref is correct
  1. S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="REINDEX"
  1. D UPDATE^DIE("","FDA","CTRLIEN")
  1. K FDA
  1. N SUB,DA,DIK,GMRAIEN,CLASS
  1. S SUB=0 F S SUB=$O(^GMR(120.8,SUB)) Q:'+SUB I $D(^GMR(120.8,SUB,3)) D
  1. .S GMRAIEN=+$P($G(^GMR(120.8,SUB,0)),U) Q:'GMRAIEN
  1. .S CLASS="" F S CLASS=$O(^GMR(120.8,"APC",GMRAIEN,CLASS)) Q:CLASS="" K ^GMR(120.8,"APC",GMRAIEN,CLASS,SUB)
  1. .S DA(1)=SUB
  1. .S DIK="^GMR(120.8,DA(1),3,"
  1. .S DIK(1)=".01^ADRG3"
  1. .D ENALL^DIK ;Reset the drug class xref
  1. ;
  1. MORE ; REINDEXING
  1. D CTRKDL^PSNPPSMS("Reindexing")
  1. ;now the APD
  1. K ^PS(50.416,"APD") S DA=0 F S DA=$O(^PS(50.416,DA)),K=0 Q:'DA F S K=$O(^PS(50.416,DA,1,K)) Q:'K S X=^(K,0),^PS(50.416,"APD",X,DA)=""
  1. ;now the interactions
  1. K ^PS(56,"APD") S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA K PSN1,PSN2 S PSN1=$P(^(DA,0),"^",2),PSN2=$P(^(0),"^",3) D
  1. .S NA="" F S NA=$O(^PS(50.416,PSN1,1,"B",NA)) Q:NA="" S PSN1(NA)=""
  1. .S PSN11=0 F S PSN11=$O(^PS(50.416,"APS",PSN1,PSN11)),NA="" Q:'PSN11 F S NA=$O(^PS(50.416,PSN11,1,"B",NA)) Q:NA="" S PSN1(NA)=""
  1. .S NA="" F S NA=$O(^PS(50.416,PSN2,1,"B",NA)) Q:NA="" S PSN2(NA)=""
  1. .S PSN21=0 F S PSN21=$O(^PS(50.416,"APS",PSN2,PSN21)),NA="" Q:'PSN21 F S NA=$O(^PS(50.416,PSN21,1,"B",NA)) Q:NA="" S PSN2(NA)=""
  1. .S PSN1="" F S PSN1=$O(PSN1(PSN1)),PSN2="" Q:PSN1="" F S PSN2=$O(PSN2(PSN2)) Q:PSN2="" S ^PS(56,"APD",PSN1,PSN2,DA)="",^PS(56,"APD",PSN2,PSN1,DA)=""
  1. ;
  1. D ^PSNPPSCL
  1. D ERRORMS^PSNPPSMS
  1. ;
  1. QUIT ;
  1. ;D UPDATE^XPDID(XPDIDTOT)
  1. K CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
  1. K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1. K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$J),^TMP("PSN PPSN ERR",$J),^TMP("PSNINGRED",$J)
  1. Q
  1. ;
  1. ERROR ;Track file errors
  1. D APPERROR^%ZTER("PPSN ERROR")
  1. N PSNERRC,ERRFILE,ERRIEN
  1. S PSNERROR=PSNERROR+1,PSNERRC=0,ERRFILE=0,ERRIEN=0
  1. F S PSNERRC=$O(ERROR("DIERR",PSNERRC)) Q:'PSNERRC D:$D(ERROR("DIERR",PSNERRC,"TEXT",1))
  1. .S ERRFILE=$G(ERROR("DIERR",PSNERRC,"PARAM","FILE")) S ERRIEN=$S("^351^352^311^"[("^"_$G(ERROR("DIERR",PSNERRC))_"^"):" ",1:$P(DIA,"^"))
  1. .S ^TMP("PSN PPSN ERR",$J,PSNTMPN,$S($G(ERRFILE):ERRFILE,$G(FILE)'="":FILE,1:ROOT),ERRIEN,$P(DIA,"^",3),PSNERROR)=ERROR("DIERR",PSNERRC,"TEXT",1)_"|"_$S($G(FILE)'="":FILE,1:ROOT)_"-"_$P(DIA,"^",3)_"|"_NEW
  1. Q
  1. ;
  1. ERROR2(PSNERRN,PSNERRF,PSNERRIE,PSNERRFL,PSNERRTY) ;Track DICN errors
  1. D APPERROR^%ZTER("PPSN ERROR2")
  1. S PSNERROR=PSNERROR+1,PSNERRC=""
  1. S ^TMP("PSN PPSN ERR",$J,PSNERRN,PSNERRF,PSNERRIE,PSNERRFL,PSNERRTY)=DIA_"^"_NEW
  1. Q
  1. STRIP(X) ; Strip control characters
  1. N I,Y
  1. S Y="" F I=1:1:$L(X) S:$A(X,I)>31 Y=Y_$E(X,I)
  1. Q Y