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